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      deriving Show
  44
  45 -- categorises primops
  46 data Category
  47    = Dyadic | Monadic | Compare | GenPrimOp
  48      deriving Show
  49
  50 -- types
  51 data Ty
  52    = TyF    Ty Ty
  53    | TyApp  TyCon [Ty]
  54    | TyVar  TyVar
  55    | TyUTup [Ty]   -- unboxed tuples; just a TyCon really,
  56                    -- but convenient like this
  57    deriving (Eq,Show)
  58
  59 type TyVar = String
  60 type TyCon = String
  61
  62
  63 ------------------------------------------------------------------
  64 -- Sanity checking -----------------------------------------------
  65 ------------------------------------------------------------------
  66
  67 {- Do some simple sanity checks:
  68     * all the default field names are unique
  69     * for each PrimOpSpec, all override field names are unique
  70     * for each PrimOpSpec, all overriden field names
  71           have a corresponding default value
  72     * that primop types correspond in certain ways to the
  73       Category: eg if Comparison, the type must be of the form
  74          T -> T -> Bool.
  75    Dies with "error" if there's a problem, else returns ().
  76 -}
  77 myseqAll :: [()] -> a -> a
  78 myseqAll (():ys) x = myseqAll ys x
  79 myseqAll []      x = x
  80
  81 sanityTop :: Info -> ()
  82 sanityTop (Info defs entries)
  83    = let opt_names = map get_attrib_name defs
  84          primops = filter is_primop entries
  85      in
  86      if   length opt_names /= length (nub opt_names)
  87      then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
  88      else myseqAll (map (sanityPrimOp opt_names) primops) ()
  89
  90 sanityPrimOp :: [String] -> Entry -> ()
  91 sanityPrimOp def_names p
  92    = let p_names = map get_attrib_name (opts p)
  93          p_names_ok
  94             = length p_names == length (nub p_names)
  95               && all (`elem` def_names) p_names
  96          ty_ok = sane_ty (cat p) (ty p)
  97      in
  98          if   not p_names_ok
  99          then error ("attribute names are non-unique or have no default in\n" ++
 100                      "info for primop " ++ cons p ++ "\n")
 101          else
 102          if   not ty_ok
 103          then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
 104                      " category " ++ show (cat p) ++ "\n")
 105          else ()
 106
 107 sane_ty :: Category -> Ty -> Bool
 108 sane_ty Compare (TyF t1 (TyF t2 td))
 109    | t1 == t2 && td == TyApp "Bool" []  = True
 110 sane_ty Monadic (TyF t1 td)
 111    | t1 == td  = True
 112 sane_ty Dyadic (TyF t1 (TyF t2 td))
 113    | t1 == td && t2 == td  = True
 114 sane_ty GenPrimOp _
 115    = True
 116 sane_ty _ _
 117    = False
 118
 119 get_attrib_name :: Option -> String
 120 get_attrib_name (OptionFalse nm) = nm
 121 get_attrib_name (OptionTrue nm)  = nm
 122 get_attrib_name (OptionString nm _) = nm
 123
 124 lookup_attrib :: String -> [Option] -> Maybe Option
 125 lookup_attrib _ [] = Nothing
 126 lookup_attrib nm (a:as)
 127     = if get_attrib_name a == nm then Just a else lookup_attrib nm as
 128