Fully generalization Module Ann to Module a

src/CoreFn/Annotation.purs

@@ -0,0 +1,59 @@
+module CoreFn.Annotation where
+
+import Prelude
+
+import CoreFn.Ann (Ann(..), SourcePos(..), SourceSpan(..))
+import CoreFn.Common (identFromJSON, object)
+import CoreFn.Meta (ConstructorType(..), Meta(..))
+import CoreFn.Module (FilePath)
+import Data.Maybe (Maybe(..))
+import Data.Newtype (unwrap)
+import Data.Traversable (traverse)
+import Foreign (F, Foreign, ForeignError(..), fail, readArray, readInt, readNull, readString)
+import Foreign.Index (index, readProp)
+
+class Annotation a where
+  annFromJSON :: FilePath -> Foreign -> F a
+
+instance annotationAnn :: Annotation Ann where
+  annFromJSON modulePath = object \json -> do
+    sourceSpan <- readProp "sourceSpan" json >>= sourceSpanFromJSON
+    meta <- readProp "meta" json >>= readNull >>= traverse metaFromJSON
+    pure $ Ann { sourceSpan, comments: [], type: Nothing, meta }
+    where
+    sourceSpanFromJSON :: Foreign -> F SourceSpan
+    sourceSpanFromJSON = object \json -> do
+      spanStart <- readProp "start" json >>= sourcePosFromJSON
+      spanEnd <- readProp "end" json >>= sourcePosFromJSON
+      pure $ SourceSpan { spanName: unwrap modulePath, spanStart, spanEnd }
+
+    sourcePosFromJSON :: Foreign -> F SourcePos
+    sourcePosFromJSON json = do
+      sourcePosLine <- index json 0 >>= readInt
+      sourcePosColumn <- index json 1 >>= readInt
+      pure $ SourcePos { sourcePosLine, sourcePosColumn }
+
+    metaFromJSON :: Foreign -> F Meta
+    metaFromJSON = object $ \json -> do
+      type_ <- readProp "metaType" json >>= readString
+      case type_ of
+        "IsConstructor" -> isConstructorFromJSON json
+        "IsNewtype" -> pure IsNewtype
+        "IsTypeClassConstructor" -> pure IsTypeClassConstructor
+        "IsForeign" -> pure IsForeign
+        "IsWhere" -> pure IsWhere
+        _ -> fail $ ForeignError $ "Unknown Meta type :" <> type_
+      where
+      isConstructorFromJSON :: Foreign -> F Meta
+      isConstructorFromJSON json = do
+        ct <- readProp "constructorType" json >>= constructorTypeFromJSON
+        is <- readProp "identifiers" json >>= readArray >>= traverse identFromJSON
+        pure $ IsConstructor ct is
+
+    constructorTypeFromJSON :: Foreign -> F ConstructorType
+    constructorTypeFromJSON json = do
+      type_ <- readString json
+      case type_ of
+        "ProductType" -> pure ProductType
+        "SumType" -> pure SumType
+        _ -> fail $ ForeignError $ "Unknown ConstructorType: " <> type_

src/CoreFn/Common.purs

@@ -0,0 +1,17 @@
+module CoreFn.Common where
+
+import Prelude
+
+import CoreFn.Ident (Ident(..))
+import Foreign (F, Foreign, ForeignError(..), fail, readString, typeOf)
+
+objectType :: String
+objectType = "object"
+
+object :: forall a. (Foreign -> F a) -> Foreign -> F a
+object _ json
+  | typ <- typeOf json, typ /= objectType = fail $ TypeMismatch objectType typ
+object f json = f json
+
+identFromJSON :: Foreign -> F Ident
+identFromJSON = map Ident <<< readString

src/CoreFn/FromJSON.purs

@@ -5,75 +5,24 @@ module CoreFn.FromJSON
 import Prelude
 
 import Control.Alt ((<|>))
-import CoreFn.Ann (Ann(..), Comment(..), SourcePos(..), SourceSpan(..))
+import CoreFn.Ann (Comment(..))
+import CoreFn.Annotation (class Annotation, annFromJSON)
 import CoreFn.Binders (Binder(..))
+import CoreFn.Common (identFromJSON, object)
 import CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..))
 import CoreFn.Ident (Ident(..))
 import CoreFn.Literal (Literal(..))
-import CoreFn.Meta (ConstructorType(..), Meta(..))
 import CoreFn.Module (FilePath(..), Module(..), ModuleImport(..), Version(..))
 import CoreFn.Names (ModuleName(..), ProperName(..), Qualified(..))
 import Data.Array as Array
 import Data.Either (Either(..))
-import Foreign (F, Foreign, ForeignError(..), fail, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, typeOf)
-import Foreign.Index (index, readIndex, readProp)
-import Foreign.JSON (parseJSON)
-import Foreign.Keys (keys)
 import Data.Maybe (Maybe(..))
-import Data.Newtype (unwrap)
 import Data.Traversable (traverse)
 import Data.Tuple (Tuple(..), uncurry)
-
-objectType :: String
-objectType = "object"
-
-object :: forall a. (Foreign -> F a) -> Foreign -> F a
-object _ json
-  | typ <- typeOf json, typ /= objectType = fail $ TypeMismatch objectType typ
-object f json = f json
-
-constructorTypeFromJSON :: Foreign -> F ConstructorType
-constructorTypeFromJSON json = do
-  type_ <- readString json
-  case type_ of
-    "ProductType" -> pure ProductType
-    "SumType" -> pure SumType
-    _ -> fail $ ForeignError $ "Unknown ConstructorType: " <> type_
-
-metaFromJSON :: Foreign -> F Meta
-metaFromJSON = object $ \json -> do
-  type_ <- readProp "metaType" json >>= readString
-  case type_ of
-    "IsConstructor" -> isConstructorFromJSON json
-    "IsNewtype" -> pure IsNewtype
-    "IsTypeClassConstructor" -> pure IsTypeClassConstructor
-    "IsForeign" -> pure IsForeign
-    "IsWhere" -> pure IsWhere
-    _ -> fail $ ForeignError $ "Unknown Meta type :" <> type_
-  where
-  isConstructorFromJSON :: Foreign -> F Meta
-  isConstructorFromJSON json = do
-    ct <- readProp "constructorType" json >>= constructorTypeFromJSON
-    is <- readProp "identifiers" json >>= readArray >>= traverse identFromJSON
-    pure $ IsConstructor ct is
-
-annFromJSON :: FilePath -> Foreign -> F Ann
-annFromJSON modulePath = object \json -> do
-  sourceSpan <- readProp "sourceSpan" json >>= sourceSpanFromJSON
-  meta <- readProp "meta" json >>= readNull >>= traverse metaFromJSON
-  pure $ Ann { sourceSpan, comments: [], type: Nothing, meta }
-  where
-  sourceSpanFromJSON :: Foreign -> F SourceSpan
-  sourceSpanFromJSON = object \json -> do
-    spanStart <- readProp "start" json >>= sourcePosFromJSON
-    spanEnd <- readProp "end" json >>= sourcePosFromJSON
-    pure $ SourceSpan { spanName: unwrap modulePath, spanStart, spanEnd }
-
-  sourcePosFromJSON :: Foreign -> F SourcePos
-  sourcePosFromJSON json = do
-    sourcePosLine <- index json 0 >>= readInt
-    sourcePosColumn <- index json 1 >>= readInt
-    pure $ SourcePos { sourcePosLine, sourcePosColumn }
+import Foreign (F, Foreign, ForeignError(..), fail, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString)
+import Foreign.Index (readIndex, readProp)
+import Foreign.JSON (parseJSON)
+import Foreign.Keys (keys)
 
 literalFromJSON :: forall a. (Foreign -> F a) -> Foreign -> F (Literal a)
 literalFromJSON t = object \json -> do
@@ -104,9 +53,6 @@ literalFromJSON t = object \json -> do
       val <- readProp "value" json
       ObjectLiteral <$> recordFromJSON t val
 
-identFromJSON :: Foreign -> F Ident
-identFromJSON = map Ident <<< readString
-
 properNameFromJSON :: Foreign -> F ProperName
 properNameFromJSON = map ProperName <<< readString
 
@@ -120,10 +66,10 @@ moduleNameFromJSON :: Foreign -> F ModuleName
 moduleNameFromJSON json = map ModuleName $ readArray json
   >>= traverse properNameFromJSON
 
-moduleFromJSON :: String -> F { version :: Version, module :: Module Ann }
+moduleFromJSON :: forall a. Annotation a => String -> F { version :: Version, module :: Module a }
 moduleFromJSON = parseJSON >=> moduleFromJSON'
   where
-  moduleFromJSON' :: Foreign -> F { version :: Version, module :: Module Ann }
+  moduleFromJSON' :: Foreign -> F { version :: Version, module :: Module a }
   moduleFromJSON' = object \json -> do
     version <- map Version $ readProp "builtWith" json >>= readString
 
@@ -167,7 +113,7 @@ moduleFromJSON = parseJSON >=> moduleFromJSON'
   importFromJSON
     :: FilePath
     -> Foreign
-    -> F ModuleImport
+    -> F (ModuleImport a)
   importFromJSON modulePath = object \json -> do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     moduleName <- readProp "moduleName" json >>= moduleNameFromJSON
@@ -192,7 +138,7 @@ moduleFromJSON = parseJSON >=> moduleFromJSON'
       Just type_ -> fail $ ForeignError $ "Unknown Comment type: " <> type_
       Nothing -> fail $ ForeignError "Invalid Comment"
 
-bindFromJSON :: FilePath -> Foreign -> F (Bind Ann)
+bindFromJSON :: forall a. Annotation a => FilePath -> Foreign -> F (Bind a)
 bindFromJSON modulePath = object \json -> do
   type_ <- readProp "bindType" json >>= readString
   case type_ of
@@ -204,7 +150,7 @@ bindFromJSON modulePath = object \json -> do
         >>= traverse (object bindFromJSON')
     _ -> fail $ ForeignError $ "Unknown Bind type: " <> type_
   where
-  bindFromJSON' :: Foreign -> F (Tuple (Tuple Ann Ident) (Expr Ann))
+  bindFromJSON' :: Foreign -> F (Tuple (Tuple a Ident) (Expr a))
   bindFromJSON' json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     ident <- readProp "identifier" json >>= identFromJSON
@@ -224,7 +170,7 @@ recordFromJSON p json = readArray json >>= traverse parsePair
     a <- readIndex 1 v >>= p
     pure $ Tuple l a
 
-exprFromJSON :: FilePath -> Foreign -> F (Expr Ann)
+exprFromJSON :: forall a. Annotation a => FilePath -> Foreign -> F (Expr a)
 exprFromJSON modulePath = object \json -> do
   type_ <- readProp "type" json >>= readString
   case type_ of
@@ -239,55 +185,55 @@ exprFromJSON modulePath = object \json -> do
     "Let" -> letFromJSON json
     _ -> fail $ ForeignError $ "Unknown Expr type: " <> type_
   where
-  varFromJSON :: Foreign -> F (Expr Ann)
+  varFromJSON :: Foreign -> F (Expr a)
   varFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     qi <- readProp "value" json >>= qualifiedFromJSON Ident
     pure $ Var ann qi
 
-  literalExprFromJSON :: Foreign -> F (Expr Ann)
+  literalExprFromJSON :: Foreign -> F (Expr a)
   literalExprFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     lit <- readProp "value" json >>= literalFromJSON (exprFromJSON modulePath)
     pure $ Literal ann lit
 
-  constructorFromJSON :: Foreign -> F (Expr Ann)
+  constructorFromJSON :: Foreign -> F (Expr a)
   constructorFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     tyn <- readProp "typeName" json >>= properNameFromJSON
     con <- readProp "constructorName" json >>= properNameFromJSON
     is  <- readProp "fieldNames" json >>= readArray >>= traverse identFromJSON
     pure $ Constructor ann tyn con is
 
-  accessorFromJSON :: Foreign -> F (Expr Ann)
+  accessorFromJSON :: Foreign -> F (Expr a)
   accessorFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     f <- readProp "fieldName" json >>= readString
     e <- readProp "expression" json >>= exprFromJSON modulePath
     pure $ Accessor ann f e
 
-  objectUpdateFromJSON :: Foreign -> F (Expr Ann)
+  objectUpdateFromJSON :: Foreign -> F (Expr a)
   objectUpdateFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     e <- readProp "expression" json >>= exprFromJSON modulePath
     us <- readProp "updates" json >>= recordFromJSON (exprFromJSON modulePath)
     pure $ ObjectUpdate ann e us
 
-  absFromJSON :: Foreign -> F (Expr Ann)
+  absFromJSON :: Foreign -> F (Expr a)
   absFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     idn <- readProp "argument" json >>= identFromJSON
     e <- readProp "body" json >>= exprFromJSON modulePath
     pure $ Abs ann idn e
 
-  appFromJSON :: Foreign -> F (Expr Ann)
+  appFromJSON :: Foreign -> F (Expr a)
   appFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     e <- readProp "abstraction" json >>= exprFromJSON modulePath
     e' <- readProp "argument" json >>= exprFromJSON modulePath
     pure $ App ann e e'
 
-  caseFromJSON :: Foreign -> F (Expr Ann)
+  caseFromJSON :: Foreign -> F (Expr a)
   caseFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     cs <- readProp "caseExpressions" json
@@ -298,7 +244,7 @@ exprFromJSON modulePath = object \json -> do
       >>= traverse (caseAlternativeFromJSON modulePath)
     pure $ Case ann cs cas
 
-  letFromJSON :: Foreign -> F (Expr Ann)
+  letFromJSON :: Foreign -> F (Expr a)
   letFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     bs <- readProp "binds" json
@@ -307,7 +253,7 @@ exprFromJSON modulePath = object \json -> do
     e <- readProp "expression" json >>= exprFromJSON modulePath
     pure $ Let ann bs e
 
-caseAlternativeFromJSON :: FilePath -> Foreign -> F (CaseAlternative Ann)
+caseAlternativeFromJSON :: forall a. Annotation a => FilePath -> Foreign -> F (CaseAlternative a)
 caseAlternativeFromJSON modulePath = object \json -> do
   bs <- readProp "binders" json
     >>= readArray
@@ -329,13 +275,13 @@ caseAlternativeFromJSON modulePath = object \json -> do
         , caseAlternativeResult: Right e
         }
   where
-  parseResultWithGuard :: Foreign -> F (Tuple (Expr Ann) (Expr Ann))
+  parseResultWithGuard :: Foreign -> F (Tuple (Expr a) (Expr a))
   parseResultWithGuard = object \json -> do
     g <- readProp "guard" json >>= exprFromJSON modulePath
     e <- readProp "expression" json >>= exprFromJSON modulePath
     pure $ Tuple g e
 
-binderFromJSON :: FilePath -> Foreign -> F (Binder Ann)
+binderFromJSON :: forall a. Annotation a => FilePath -> Foreign -> F (Binder a)
 binderFromJSON modulePath = object \json -> do
   type_ <- readProp "binderType" json >>= readString
   case type_ of
@@ -346,25 +292,25 @@ binderFromJSON modulePath = object \json -> do
     "NamedBinder" -> namedBinderFromJSON json
     _ -> fail $ ForeignError $ "Unknown Binder type: " <> type_
   where
-  nullBinderFromJSON :: Foreign -> F (Binder Ann)
+  nullBinderFromJSON :: Foreign -> F (Binder a)
   nullBinderFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     pure $ NullBinder ann
 
-  varBinderFromJSON :: Foreign -> F (Binder Ann)
+  varBinderFromJSON :: Foreign -> F (Binder a)
   varBinderFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     idn <- readProp "identifier" json >>= identFromJSON
     pure $ VarBinder ann idn
 
-  literalBinderFromJSON :: Foreign -> F (Binder Ann)
+  literalBinderFromJSON :: Foreign -> F (Binder a)
   literalBinderFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     lit <- readProp "literal" json
       >>= literalFromJSON (binderFromJSON modulePath)
     pure $ LiteralBinder ann lit
 
-  constructorBinderFromJSON :: Foreign -> F (Binder Ann)
+  constructorBinderFromJSON :: Foreign -> F (Binder a)
   constructorBinderFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     tyn <- readProp "typeName" json >>= qualifiedFromJSON ProperName
@@ -374,7 +320,7 @@ binderFromJSON modulePath = object \json -> do
       >>= traverse (binderFromJSON modulePath)
     pure $ ConstructorBinder ann tyn con bs
 
-  namedBinderFromJSON :: Foreign -> F (Binder Ann)
+  namedBinderFromJSON :: Foreign -> F (Binder a)
   namedBinderFromJSON json = do
     ann <- readProp "annotation" json >>= annFromJSON modulePath
     n <- readProp "identifier" json >>= identFromJSON

src/CoreFn/Module.purs

@@ -7,7 +7,7 @@ module CoreFn.Module
 
 import Prelude
 
-import CoreFn.Ann (Comment, Ann)
+import CoreFn.Ann (Comment)
 import CoreFn.Expr (Bind)
 import CoreFn.Ident (Ident)
 import CoreFn.Names (ModuleName)
@@ -20,7 +20,7 @@ newtype Module a = Module
   { moduleComments :: Array Comment
   , moduleName :: ModuleName
   , modulePath :: FilePath
-  , moduleImports :: Array ModuleImport
+  , moduleImports :: Array (ModuleImport a)
   , moduleExports :: Array Ident
   , moduleForeign :: Array Ident
   , moduleDecls :: Array (Bind a)
@@ -44,16 +44,16 @@ instance showModule :: Show a => Show (Module a) where
     ")"
 
 
-newtype ModuleImport = ModuleImport
-  { ann :: Ann
+newtype ModuleImport a = ModuleImport
+  { ann :: a
   , moduleName :: ModuleName
   }
 
-derive instance newtypeModuleImport :: Newtype ModuleImport _
-derive instance eqModuleImport :: Eq ModuleImport
-derive instance ordModuleImport :: Ord ModuleImport
+derive instance newtypeModuleImport :: Newtype (ModuleImport a) _
+derive instance eqModuleImport :: Eq a => Eq (ModuleImport a)
+derive instance ordModuleImport :: Ord a => Ord (ModuleImport a)
 
-instance showModuleImport :: Show ModuleImport where
+instance showModuleImport :: Show a => Show (ModuleImport a) where
   show (ModuleImport moduleImport) =
     "(ModuleImport " <>
       "{ ann: " <> show moduleImport.ann <>