1 module PI
    2 
    3 ( PI
    4 , PIS
    5 
    6 , PY    -- export required by hbc ???
    7 
    8 , llit, llitp
    9 , lmany, lmany1
   10 , lsepBy, lsepBy1
   11 
   12 , lparse, opt
   13 
   14 , getopts
   15 
   16 , makeid, makenat
   17 , putprec, putarity, putform
   18 
   19 , pushlocals, poplocals, mkglobals
   20 
   21 , makeidS, makenatS
   22 , putprecS, putarityS, putformS
   23 
   24 )
   25 
   26 where
   27 
   28 -- import Trace
   29 
   30 import Options
   31 import Ids
   32 import Monad
   33 
   34 import IdStack
   35 
   36 import Parse    -- from syslib hbc
   37 
   38 
   39 
   40 -- data PI v = PI ((Opts, IdTable) -> Parser [String] (v, (Opts, IdTable)))
   41 -- unPI (PI p) = p
   42 
   43 data PY a v = PY (a -> Parser [String] (v, a))
   44 unPY (PY p) = p
   45 
   46 type PI v = PY (Opts, IdTable) v
   47 type PIS v = PY (Opts, IdStack) v
   48 
   49 ------------------------------------------------------------------------
   50 
   51 instance Functor (PY a) where
   52     fmap f (PY p) = PY (\ x -> 
   53         p x `act` (\ (v, x) -> (f v, x)))
   54 
   55 instance Monad (PY a) where
   56     return r = PY ( \ x -> succeed (r, x) )
   57     PY p >>= g = PY (\ x -> 
   58         p x `into` (\ (v, x') -> unPY (g v) x'))
   59 
   60 instance MonadPlus (PY a) where
   61     mzero = PY (\ x -> failP "PY.zero")
   62     (PY p) `mplus` (PY q) = PY ( \ x -> p x ||! q x )
   63 
   64 --------------------------------------------------------------------------
   65 
   66 lparse (PY p) x toks = parse (p x) toks
   67 
   68     
   69 --------------------------------------------------------------------------
   70 
   71 getopts :: PY (a, b) a
   72 getopts = PY (\ (o, i) -> succeed (o, (o, i)))
   73 
   74 --------------------------------------------------------------------------
   75 
   76 makenat :: Int -> PI Id
   77 makenat n = makeid (show n) Fn Fn
   78 
   79 
   80 
   81 makeid :: String -> Kind -> Kind -> PI Id
   82 makeid name look use = PY ( \ (o, i) -> 
   83         let (id, i') = findid name look use i
   84         in succeed (id, (o, i')) )
   85 
   86 putprec id level bind = PY ( \ (o, i) ->
   87         let (id', i') = changeprec i id level bind
   88         in succeed (id', (o, i')) )
   89 
   90 putarity id ar = PY ( \ (o, i) ->
   91         let (id', i') = setarity i id ar
   92         in 
   93 --           trace ("\nputarity.id : " ++ show id) $
   94 --           trace ("\nputarity.id.arity : " ++ show (maybe_idarity id)) $
   95 --           trace ("\nputarity.ar : " ++ show ar) $
   96 --           trace ("\nputarity.id'.arity : " ++ show (idarity id')) $
   97                 succeed (id', (o, i')) )
   98 
   99 putform id cs = PY ( \ (o, i) ->
  100         let (id', i') = setform i id cs
  101         in succeed (id', (o, i')) )
  102 
  103 -----------------------------------------------------------------------
  104 
  105 makenatS :: Bool -> Int -> PIS Id
  106 makenatS def n = makeidS def (show n) Fn Fn
  107 
  108 makeidS :: Bool -> String -> Kind -> Kind -> PIS Id
  109 makeidS def name look use = PY ( \ (o, i) -> 
  110         let (id, i') = findidS def name look use i
  111         in succeed (id, (o, i')) )
  112 
  113 putprecS id level bind = PY ( \ (o, i) ->
  114         let (id', i') = changeprecS i id level bind
  115         in succeed (id', (o, i')) )
  116 
  117 putarityS id ar = PY ( \ (o, i) ->
  118         let (id', i') = setarityS i id ar
  119         in 
  120 --           trace ("\nputarity.id : " ++ show id) $
  121 --           trace ("\nputarity.id.arity : " ++ show (maybe_idarity id)) $
  122 --           trace ("\nputarity.ar : " ++ show ar) $
  123 --           trace ("\nputarity.id'.arity : " ++ show (idarity id')) $
  124                 succeed (id', (o, i')) )
  125 
  126 putformS id cs = PY ( \ (o, i) ->
  127         let (id', i') = setformS i id cs
  128         in succeed (id', (o, i')) )
  129 
  130 ---------------------------------------------------------------------
  131 
  132 
  133 lift :: Parser [String] v -> PY a v
  134 lift p = PY (\ x -> p `act` \ v -> (v, x) )
  135 
  136 ---------------------------------------------------------------------
  137 
  138 pushlocals :: PIS ()
  139 pushlocals = PY ( \ (o, i) -> succeed ((), (o, pushlocs i)) )
  140 
  141 poplocals :: PIS ()
  142 poplocals = PY ( \ (o, i) -> succeed ((), (o, poplocs i)) )
  143 
  144 mkglobals :: PIS ()
  145 mkglobals = PY ( \ (o, i) -> succeed ((), (o, mkglobs i)) )
  146 
  147 
  148 ---------------------------------------------------------------------
  149 
  150 llit x = lift (lit x)
  151 
  152 llitp msg p = lift (litp msg p)
  153 
  154 lmany1 p = do { x <- p; xs <- lmany p; return (x : xs) }
  155 lmany  p = lmany1 p `mplus` return []
  156 
  157 p `lsepBy1` q = 
  158     do  { x <- p
  159         ; ys <- lmany ( do { q; y <- p; return y } )
  160         ; return (x : ys)
  161         }
  162 
  163 p `lsepBy` q = p `lsepBy1` q `mplus` return []
  164 
  165 
  166 opt p = fmap Just p `mplus` return Nothing
  167 
  168 ----------------------------------------------------------------------
  169 
  170