essential typing (#20)

smucclaw · Mar 1, 2021 · f38ea92 · f38ea92
1 parent 3b5a0e4
commit f38ea92
Show file tree

Hide file tree

Showing 6 changed files with 130 additions and 252 deletions.
diff --git a/Parser.y b/Parser.y
diff --git a/exe/Main.hs b/exe/Main.hs
@@ -1,6 +1,7 @@
 module Main where
 
 import Parser (parseProgram)
+import Typing (tpProgram)
 import System.Environment
 import qualified ToGF as GF
 
@@ -9,7 +10,8 @@ process filepath input = do
   let ast = parseProgram filepath input
   case ast of
     Right ast -> do
-      putStrLn (show ast)
+      print (tpProgram ast)
+      --print ast
       GF.nlg ast
     Left err -> do
       putStrLn "Parser Error:"

diff --git a/l4/cr.l4 b/l4/cr.l4
@@ -38,10 +38,19 @@ class LocumSolicitor extends LegalPractitioner {
 }
 
 decl AssociatedWith: LegalPractitioner -> Appointment -> Bool
-decl AssociatedWithApp: Appointment -> BusinessEntity -> Bool
+decl AssociatedWithAppB: Appointment -> Business -> Bool
+decl AssociatedWithAppBE: Appointment -> BusinessEntity -> Bool
 
 decl SubjectTo : LegalPractitioner -> Appointment -> Bool
+decl MayAcceptApp : LegalPractitioner -> Appointment -> Bool
+decl MustNotAcceptApp : LegalPractitioner -> Appointment -> Bool
 
+decl IncompatibleDignity : Business -> Bool
+decl MateriallyInterferes : Business -> Bool
+decl UnfairAttractBusiness : Business -> Bool
+decl ShareLPRFees : Business -> Bool
+decl BusinessFirstSchedule : Business -> Bool
+decl ProhibitedBusiness : Business -> Bool
 
 # use the following declarations instead of the commented 'extends' classes ??
 # decl LawRelatedService: Business -> Bool
@@ -52,32 +61,32 @@ decl SubjectTo : LegalPractitioner -> Appointment -> Bool
 
 rule <r1a>
 for lpr: LegalPractitioner, app: Appointment
-if (exists bsn : Business. AssociatedWithApp app bsn && IncompatibleDignity bsn)
+if (exists bsn : Business. AssociatedWithAppB app bsn && IncompatibleDignity bsn)
 then MustNotAcceptApp lpr app
 
 rule <r1b>
 for lpr: LegalPractitioner, app: Appointment
-if (exists bsn : Business. AssociatedWithApp app bsn && MateriallyInterferes bsn)
+if (exists bsn : Business. AssociatedWithAppB app bsn && MateriallyInterferes bsn)
 then MustNotAcceptApp lpr app
 
 rule <r1c>
 for lpr: LegalPractitioner, app: Appointment
-if (exists bsn : Business. AssociatedWithApp app bsn && UnfairAttractBusiness bsn)
+if (exists bsn : Business. AssociatedWithAppB app bsn && UnfairAttractBusiness bsn)
 then MustNotAcceptApp lpr app
 
 rule <r1d>
 for lpr: LegalPractitioner, app: Appointment
-if (exists bsn : Business. AssociatedWithApp app bsn && ShareLPRFees bsn)
+if (exists bsn : Business. AssociatedWithAppB app bsn && ShareLPRFees bsn)
 then MustNotAcceptApp lpr app
 
 rule <r1e>
 for lpr: LegalPractitioner, app: Appointment
-if (exists bsn : Business. AssociatedWithApp app bsn && BusinessFirstSchedule bsn)
+if (exists bsn : Business. AssociatedWithAppB app bsn && BusinessFirstSchedule bsn)
 then MustNotAcceptApp lpr app
 
 rule <r1f>
 for lpr: LegalPractitioner, app: Appointment
-if (exists bsn : Business. AssociatedWithApp app bsn && ProhibitedBusiness bsn)
+if (exists bsn : Business. AssociatedWithAppB app bsn && ProhibitedBusiness bsn)
 then MustNotAcceptApp lpr app
 
 # first condition of IF: neg. of precond of rule 1a

diff --git a/src/Exec.hs b/src/Exec.hs
@@ -38,7 +38,7 @@ lift_barith_op ba c1 c2 = case (c1, c2) of
 
 lift_binop_expr :: BinOp -> Expr Tp -> Expr Tp -> Expr Tp
 lift_binop_expr bop e1 e2 = case (bop, e1, e2) of
-    (BArith ba, ValE t1 c1, ValE t2 c2) -> ValE (tp_barith t1 t2 ba) (lift_barith_op ba c1 c2)
+    (BArith ba, ValE t1 c1, ValE t2 c2) -> ValE (tpBarith t1 t2 ba) (lift_barith_op ba c1 c2)
 
 constr_clos :: Tp -> Expr Tp -> Expr Tp -> Expr Tp
 constr_clos rtp f a = case f of

diff --git a/src/Syntax.hs b/src/Syntax.hs
@@ -11,7 +11,8 @@ newtype GFAnnot = GFAnnot Integer
 
 ----- Names 
 type VarName = String
---  deriving (Eq, Ord, Show, Read)
+type RuleName = String
+
 data AnnotClassName = AClsNm String GFAnnot
   deriving (Eq, Ord, Show, Read)
 newtype ClassName = ClsNm String
@@ -20,21 +21,10 @@ newtype FieldName = FldNm String
   deriving (Eq, Ord, Show, Read)
 data AnnotFieldName = AFldNm String GFAnnot
   deriving (Eq, Ord, Show, Read)
-newtype RuleName = RlNm String
-  deriving (Eq, Ord, Show, Read)
 newtype PartyName = PtNm String
   deriving (Eq, Ord, Show, Read)
 
 
-
-annotClassName2ClassName :: AnnotClassName -> ClassName
-annotClassName2ClassName (AClsNm cn a) = ClsNm cn
-
-annotFieldName2FieldName :: AnnotFieldName -> FieldName
-annotFieldName2FieldName (AFldNm fn a) = FldNm fn
-
-
-
 ----- Program
 
 data Program ct et = Program [Mapping] [ClassDecl ct] [VarDecl] [Rule et] [Assertion et] 
@@ -77,16 +67,6 @@ def_of_class_decl (ClassDecl _ cd) = cd
 fields_of_class_def :: ClassDef t -> [FieldDecl]
 fields_of_class_def (ClassDef scn fds) = fds
 
-data GeneralRule = TBD
-  deriving (Eq, Ord, Show, Read)
-data Module t = Mdl [ClassDecl t] [GeneralRule]
-  deriving (Eq, Ord, Show, Read)
-
-class_decls_of_module :: Module t -> [ClassDecl t]
-class_decls_of_module (Mdl cds _) = cds
-
-rules_of_module :: Module t -> [GeneralRule]
-rules_of_module (Mdl _ rls) = rls
 
 -- Custom Classes and Preable Module
 -- some custom classes - should eventually go into a prelude and not be hard-wired
@@ -122,7 +102,6 @@ customCs = [objectC, qualifNumC, currencyC] ++ currencyCs ++ [timeC] ++ timeCs +
 -}
 
 customCs = [objectC]
-preambleMdl = Mdl customCs []
 
 ----- Expressions 
 data Val
@@ -210,7 +189,7 @@ data Cmd t
   deriving (Eq, Ord, Show, Read)
 
 
-data Rule t = Rule VarName [VarDecl] (Expr t) (Expr t)
+data Rule t = Rule RuleName [VarDecl] (Expr t) (Expr t)
   deriving (Eq, Ord, Show, Read)
 
 data Assertion t = Assertion (Expr t)