1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106

------------------------------------------------------------------------------
--- A type is sensible if there exists at least one value of this type.
--- This module contains an analysis which associates to each type
--- constructor the following information:
--- * sensible, i.e., there is always some value of this type
--- * parametric sensible, i.e., it is sensible of all type arguments
---   are instantiated with sensible types
--- * not sensible, i.e., maybe not sensible
------------------------------------------------------------------------------

{-# OPTIONS_FRONTEND -Wno-incomplete-patterns #-}

module Analysis.SensibleTypes
  ( Sensible(..), showSensible, sensibleType )
 where

import Data.Maybe
import FlatCurry.Types
import FlatCurry.Goodies
import RW.Base
import System.IO

import Analysis.Types
import Analysis.ProgInfo

------------------------------------------------------------------------------
--- Datatype to represent sensible type information.
data Sensible = NotSensible | PSensible | Sensible
  deriving (Show, Read, Eq)

-- Show higher-order information as a string.
showSensible :: AOutFormat -> Sensible -> String
showSensible _ Sensible    = "sensible"
showSensible _ PSensible   = "parametric sensible"
showSensible _ NotSensible = "not sensible"

lubSens :: Sensible -> Sensible -> Sensible
lubSens Sensible    _           = Sensible
lubSens PSensible   Sensible    = Sensible
lubSens PSensible   PSensible   = PSensible
lubSens PSensible   NotSensible = PSensible
lubSens NotSensible x           = x

------------------------------------------------------------------------
-- Analysis of sensible types

sensibleType :: Analysis Sensible
sensibleType = dependencyTypeAnalysis "SensibleType" NotSensible sensOfType

-- predefined sensible data types
predefinedSensibles :: [QName]
predefinedSensibles = [pre "Int", pre "Float", pre "Char", pre "IO"]
 where pre tc = ("Prelude",tc)

sensOfType :: TypeDecl -> [(QName,Sensible)] -> Sensible
sensOfType (TypeSyn _ _ _ typeExpr) usedtypes =
  sensOfTypeExpr usedtypes typeExpr
sensOfType (TypeNew _ _ _ (NewCons _ _ typeExpr)) usedtypes =
  sensOfTypeExpr usedtypes typeExpr
sensOfType (Type tc _ _ conDecls) usedtypes
  | tc `elem` predefinedSensibles = Sensible
  | otherwise = foldr lubSens NotSensible (map sensOfConsDecl conDecls)
 where
   sensOfConsDecl (Cons _ _ _ typeExprs)
     | all (== Sensible)    senstargs = Sensible
     | all (/= NotSensible) senstargs = PSensible
     | otherwise                      = NotSensible
    where senstargs = map (sensOfTypeExpr usedtypes) typeExprs

-- Compute the sensibility of a type expression which depends on the
-- information about type cosntructors.
sensOfTypeExpr :: [(QName,Sensible)] -> TypeExpr -> Sensible
sensOfTypeExpr _ (TVar _)       = PSensible
sensOfTypeExpr _ (FuncType _ _) = NotSensible -- we do not know which functions
                                              -- of some type exists...
sensOfTypeExpr usedtypes (TCons tc typeExprs)
  | senstc == Sensible || (senstc == PSensible && all (==Sensible) senstargs)
  = Sensible
  | senstc == PSensible && all (/=NotSensible) senstargs
  = PSensible
  | otherwise
  = NotSensible
 where
  senstc    = maybe NotSensible id (lookup tc usedtypes)
  senstargs = map (sensOfTypeExpr usedtypes) typeExprs
sensOfTypeExpr usedtypes (ForallType _ texp) = sensOfTypeExpr usedtypes texp

------------------------------------------------------------------------------
-- ReadWrite instances:

instance ReadWrite Sensible where
  readRW _ ('0' : r0) = (NotSensible,r0)
  readRW _ ('1' : r0) = (PSensible,r0)
  readRW _ ('2' : r0) = (Sensible,r0)

  showRW _ strs0 NotSensible = (strs0,showChar '0')
  showRW _ strs0 PSensible = (strs0,showChar '1')
  showRW _ strs0 Sensible = (strs0,showChar '2')

  writeRW _ h NotSensible strs = hPutChar h '0' >> return strs
  writeRW _ h PSensible strs = hPutChar h '1' >> return strs
  writeRW _ h Sensible strs = hPutChar h '2' >> return strs

  typeOf _ = monoRWType "Sensible"

------------------------------------------------------------------------------