utils/genprimopcode/Syntax.hs

   1
   2 module Syntax where
   3
   4 import Data.List
   5
   6 ------------------------------------------------------------------
   7 -- Abstract syntax -----------------------------------------------
   8 ------------------------------------------------------------------
   9
  10 -- info for all primops; the totality of the info in primops.txt(.pp)
  11 data Info
  12    = Info [Option] [Entry]   -- defaults, primops
  13      deriving Show
  14
  15 -- info for one primop
  16 data Entry
  17     = PrimOpSpec { cons  :: String,      -- PrimOp name
  18                    name  :: String,      -- name in prog text
  19                    ty    :: Ty,          -- type
  20                    cat   :: Category,    -- category
  21                    desc  :: String,      -- description
  22                    opts  :: [Option] }   -- default overrides
  23     | PseudoOpSpec { name  :: String,      -- name in prog text
  24                      ty    :: Ty,          -- type
  25                      desc  :: String,      -- description
  26                      opts  :: [Option] }   -- default overrides
  27     | PrimTypeSpec { ty    :: Ty,      -- name in prog text
  28                      desc  :: String,      -- description
  29                      opts  :: [Option] }   -- default overrides
  30     | Section { title :: String,         -- section title
  31                 desc  :: String }        -- description
  32     deriving Show
  33
  34 is_primop :: Entry -> Bool
  35 is_primop (PrimOpSpec _ _ _ _ _ _) = True
  36 is_primop _ = False
  37
  38 -- a binding of property to value
  39 data Option
  40    = OptionFalse  String          -- name = False
  41    | OptionTrue   String          -- name = True
  42    | OptionString String String   -- name = { ... unparsed stuff ... }
  43    | OptionInteger String Int     -- name = <int>
  44      deriving Show
  45
  46 -- categorises primops
  47 data Category
  48    = Dyadic | Monadic | Compare | GenPrimOp
  49      deriving Show
  50
  51 -- types
  52 data Ty
  53    = TyF    Ty Ty
  54    | TyApp  TyCon [Ty]
  55    | TyVar  TyVar
  56    | TyUTup [Ty]   -- unboxed tuples; just a TyCon really,
  57                    -- but convenient like this
  58    deriving (Eq,Show)
  59
  60 type TyVar = String
  61 type TyCon = String
  62
  63
  64 ------------------------------------------------------------------
  65 -- Sanity checking -----------------------------------------------
  66 ------------------------------------------------------------------
  67
  68 {- Do some simple sanity checks:
  69     * all the default field names are unique
  70     * for each PrimOpSpec, all override field names are unique
  71     * for each PrimOpSpec, all overriden field names
  72           have a corresponding default value
  73     * that primop types correspond in certain ways to the
  74       Category: eg if Comparison, the type must be of the form
  75          T -> T -> Bool.
  76    Dies with "error" if there's a problem, else returns ().
  77 -}
  78 myseqAll :: [()] -> a -> a
  79 myseqAll (():ys) x = myseqAll ys x
  80 myseqAll []      x = x
  81
  82 sanityTop :: Info -> ()
  83 sanityTop (Info defs entries)
  84    = let opt_names = map get_attrib_name defs
  85          primops = filter is_primop entries
  86      in
  87      if   length opt_names /= length (nub opt_names)
  88      then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
  89      else myseqAll (map (sanityPrimOp opt_names) primops) ()
  90
  91 sanityPrimOp :: [String] -> Entry -> ()
  92 sanityPrimOp def_names p
  93    = let p_names = map get_attrib_name (opts p)
  94          p_names_ok
  95             = length p_names == length (nub p_names)
  96               && all (`elem` def_names) p_names
  97          ty_ok = sane_ty (cat p) (ty p)
  98      in
  99          if   not p_names_ok
 100          then error ("attribute names are non-unique or have no default in\n" ++
 101                      "info for primop " ++ cons p ++ "\n")
 102          else
 103          if   not ty_ok
 104          then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
 105                      " category " ++ show (cat p) ++ "\n")
 106          else ()
 107
 108 sane_ty :: Category -> Ty -> Bool
 109 sane_ty Compare (TyF t1 (TyF t2 td))
 110    | t1 == t2 && td == TyApp "Bool" []  = True
 111 sane_ty Monadic (TyF t1 td)
 112    | t1 == td  = True
 113 sane_ty Dyadic (TyF t1 (TyF t2 td))
 114    | t1 == td && t2 == td  = True
 115 sane_ty GenPrimOp _
 116    = True
 117 sane_ty _ _
 118    = False
 119
 120 get_attrib_name :: Option -> String
 121 get_attrib_name (OptionFalse nm) = nm
 122 get_attrib_name (OptionTrue nm)  = nm
 123 get_attrib_name (OptionString nm _) = nm
 124 get_attrib_name (OptionInteger nm _) = nm
 125
 126 lookup_attrib :: String -> [Option] -> Maybe Option
 127 lookup_attrib _ [] = Nothing
 128 lookup_attrib nm (a:as)
 129     = if get_attrib_name a == nm then Just a else lookup_attrib nm as
 130