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
107
108
109
110
111
112
113
114

------------------------------------------------------------------------
--- Analysis of higher-order properties of types and operations.
------------------------------------------------------------------------

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

module Analysis.HigherOrder
  (Order(..), showOrder, hiOrdType, hiOrdCons, hiOrdFunc)
 where

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

-- datatype order: higher-order or first-order
data Order = HO | FO
  deriving (Show, Read, Eq)

-- Show higher-order information as a string.
showOrder :: AOutFormat -> Order -> String
showOrder _ HO = "higher-order"
showOrder _ FO = "first-order"

hoOr :: Order -> Order -> Order
hoOr HO _ = HO
hoOr FO x = x

------------------------------------------------------------------------
-- higher-order data type analysis

hiOrdType :: Analysis Order
hiOrdType =  dependencyTypeAnalysis "HiOrderType" FO orderOfType

orderOfType :: TypeDecl -> [(QName,Order)] -> Order

orderOfType (Type _ _ _ conDecls) usedtypes =
 hoOr (foldr hoOr FO (map orderOfConsDecl conDecls))
      (foldr hoOr FO (map snd usedtypes))
 where
   orderOfConsDecl (Cons _ _ _ typeExprs) =
     foldr hoOr FO (map orderOfTypeExpr typeExprs)

orderOfType (TypeSyn _ _ _ typeExpr) usedtypes =
 hoOr (orderOfTypeExpr typeExpr) (foldr hoOr FO (map snd usedtypes))

orderOfType (TypeNew _ _ _ (NewCons _ _ typeExpr)) usedtypes =
 hoOr (orderOfTypeExpr typeExpr) (foldr hoOr FO (map snd usedtypes))


-- compute the order of a type expression (ignore the type constructors,
-- i.e., check whether this expression contains a `FuncType`).
orderOfTypeExpr :: TypeExpr -> Order
orderOfTypeExpr (TVar _) = FO
orderOfTypeExpr (FuncType _ _) = HO
orderOfTypeExpr (TCons _ typeExprs) =
  foldr hoOr FO (map orderOfTypeExpr typeExprs)
orderOfTypeExpr (ForallType _ texp) = orderOfTypeExpr texp

-----------------------------------------------------------------------
-- higher-order constructor analysis

hiOrdCons :: Analysis Order
hiOrdCons =  simpleConstructorAnalysis "HiOrderConstr" orderOfConsDecl
 where
   orderOfConsDecl (Cons _ _ _ typeExprs) _ =
     foldr hoOr FO (map orderOfTypeExpr typeExprs)


-----------------------------------------------------------------------
-- higher-order function analysis

hiOrdFunc :: Analysis Order
hiOrdFunc = combinedSimpleFuncAnalysis "HiOrderFunc" hiOrdType orderOfFunc

orderOfFunc :: ProgInfo Order -> FuncDecl-> Order
orderOfFunc orderMap func =
  orderOfFuncTypeArity orderMap (funcType func) (funcArity func)

orderOfFuncTypeArity :: ProgInfo Order -> TypeExpr -> Int -> Order
orderOfFuncTypeArity orderMap functype arity =
  if arity==0
  then
   case functype of
     FuncType _ _   -> HO
     TVar tv        -> if tv == (-42) then HO else FO
     TCons x (y:ys) -> hoOr (orderOfFuncTypeArity orderMap y 0)
                            (orderOfFuncTypeArity orderMap (TCons x ys) 0)
     TCons tc []    -> fromMaybe FO (lookupProgInfo tc orderMap)
     _              -> FO
  else let (FuncType x y) = functype
        in hoOr (orderOfFuncTypeArity orderMap x 0)
                (orderOfFuncTypeArity orderMap y (arity-1))

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

instance ReadWrite Order where
  readRW _ ('0' : r0) = (HO,r0)
  readRW _ ('1' : r0) = (FO,r0)

  showRW _ strs0 HO = (strs0,showChar '0')
  showRW _ strs0 FO = (strs0,showChar '1')

  writeRW _ h HO strs = hPutChar h '0' >> return strs
  writeRW _ h FO strs = hPutChar h '1' >> return strs

  typeOf _ = monoRWType "Order"

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