├── .gitignore ├── .travis.yml ├── spago.dhall ├── README.md ├── packages.dhall ├── test ├── Main.purs └── CoreFn │ └── FromJSON.purs ├── src └── CoreFn │ ├── Ident.purs │ ├── Literal.purs │ ├── Meta.purs │ ├── Binders.purs │ ├── Names.purs │ ├── Module.purs │ ├── Expr.purs │ ├── Ann.purs │ └── FromJSON.purs └── LICENSE /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc-package/ 7 | /.psc* 8 | /.purs* 9 | /.psa* 10 | /.spago 11 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: node_js 2 | dist: trusty 3 | sudo: required 4 | node_js: stable 5 | install: 6 | - npm install -g spago@0.15.2 purescript@0.13.6 7 | script: 8 | - spago test 9 | -------------------------------------------------------------------------------- /spago.dhall: -------------------------------------------------------------------------------- 1 | { name = "corefn" 2 | , dependencies = 3 | [ "foreign-generic" 4 | , "profunctor" 5 | , "spec-discovery" 6 | ] 7 | , packages = ./packages.dhall 8 | , sources = [ "src/**/*.purs", "test/**/*.purs" ] 9 | } 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purescript-corefn 2 | 3 | [![Build Status](https://travis-ci.org/paulyoung/purescript-corefn.svg?branch=master)](https://travis-ci.org/paulyoung/purescript-corefn) 4 | 5 | A library for working with the PureScript functional core. 6 | -------------------------------------------------------------------------------- /packages.dhall: -------------------------------------------------------------------------------- 1 | let upstream = 2 | https://github.com/purescript/package-sets/releases/download/psc-0.13.6-20200507/packages.dhall sha256:9c1e8951e721b79de1de551f31ecb5a339e82bbd43300eb5ccfb1bf8cf7bbd62 3 | 4 | let overrides = {=} 5 | 6 | let additions = {=} 7 | 8 | in upstream // overrides // additions 9 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | import Effect (Effect) 5 | import Effect.Aff (launchAff_) 6 | import Test.Spec.Discovery (discover) 7 | import Test.Spec.Reporter.Console (consoleReporter) 8 | import Test.Spec.Runner (runSpec) 9 | 10 | main :: Effect Unit 11 | main = 12 | launchAff_ do 13 | specs <- discover "Test\\.CoreFn\\.*" 14 | runSpec [ consoleReporter ] specs 15 | -------------------------------------------------------------------------------- /src/CoreFn/Ident.purs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Names for value identifiers 3 | -- 4 | module CoreFn.Ident 5 | ( Ident(..) 6 | ) where 7 | 8 | import Prelude 9 | 10 | import Data.Maybe (Maybe) 11 | 12 | data Ident 13 | -- | 14 | -- An alphanumeric identifier 15 | -- 16 | = Ident String 17 | -- | 18 | -- A generated name for an identifier 19 | -- 20 | | GenIdent (Maybe String) Int 21 | -- | 22 | -- A generated name used only for type-checking 23 | -- 24 | | UnusedIdent 25 | 26 | derive instance eqIdent :: Eq Ident 27 | derive instance ordIdent :: Ord Ident 28 | 29 | instance showIdent :: Show Ident where 30 | show (Ident s) = "(Ident " <> show s <> ")" 31 | show (GenIdent s i) = "(GenIdent " <> show s <> " " <> show i <> ")" 32 | show UnusedIdent = "UnusedIdent" 33 | -------------------------------------------------------------------------------- /src/CoreFn/Literal.purs: -------------------------------------------------------------------------------- 1 | module CoreFn.Literal where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either, either) 6 | import Data.Tuple (Tuple) 7 | 8 | -- | 9 | -- Data type for literal values. Parameterised so it can be used for Exprs and 10 | -- Binders. 11 | -- 12 | data Literal a 13 | -- | 14 | -- A numeric literal 15 | -- 16 | = NumericLiteral (Either Int Number) 17 | -- | 18 | -- A string literal 19 | -- 20 | | StringLiteral String 21 | -- | 22 | -- A character literal 23 | -- 24 | | CharLiteral Char 25 | -- | 26 | -- A boolean literal 27 | -- 28 | | BooleanLiteral Boolean 29 | -- | 30 | -- An array literal 31 | -- 32 | | ArrayLiteral (Array a) 33 | -- | 34 | -- An object literal 35 | -- 36 | | ObjectLiteral (Array (Tuple String a)) 37 | 38 | derive instance eqLiteral :: Eq a => Eq (Literal a) 39 | derive instance functorLiteral :: Functor Literal 40 | derive instance ordLiteral :: Ord a => Ord (Literal a) 41 | 42 | instance showLiteral :: Show a => Show (Literal a) where 43 | show (NumericLiteral e) = "(NumericLiteral " <> either show show e <> ")" 44 | show (StringLiteral s) = "(StringLiteral " <> show s <> ")" 45 | show (CharLiteral c) = "(CharLiteral " <> show c <> ")" 46 | show (BooleanLiteral b) = "(BooleanLiteral " <> show b <> ")" 47 | show (ArrayLiteral a) = "(ArrayLiteral " <> show a <> ")" 48 | show (ObjectLiteral o) = "(ObjectLiteral" <> show o <> ")" 49 | -------------------------------------------------------------------------------- /src/CoreFn/Meta.purs: -------------------------------------------------------------------------------- 1 | module CoreFn.Meta where 2 | 3 | import Prelude 4 | 5 | import CoreFn.Ident (Ident) 6 | 7 | -- | 8 | -- Metadata annotations 9 | -- 10 | data Meta 11 | -- | 12 | -- The contained value is a data constructor 13 | -- 14 | = IsConstructor ConstructorType (Array Ident) 15 | -- | 16 | -- The contained value is a newtype 17 | -- 18 | | IsNewtype 19 | -- | 20 | -- The contained value is a typeclass dictionary constructor 21 | -- 22 | | IsTypeClassConstructor 23 | -- | 24 | -- The contained reference is for a foreign member 25 | -- 26 | | IsForeign 27 | -- | 28 | -- The contained value is a where clause 29 | -- 30 | | IsWhere 31 | 32 | derive instance eqMeta :: Eq Meta 33 | derive instance ordMeta :: Ord Meta 34 | 35 | instance showMeta :: Show Meta where 36 | show (IsConstructor c is) = 37 | "(IsConstructor " <> show c <> " " <> show is <> ")" 38 | show IsNewtype = "IsNewtype" 39 | show IsTypeClassConstructor = "IsTypeClassConstructor" 40 | show IsForeign = "IsForeign" 41 | show IsWhere = "IsWhere" 42 | 43 | 44 | -- | 45 | -- Data constructor metadata 46 | -- 47 | data ConstructorType 48 | -- | 49 | -- The constructor is for a type with a single constructor 50 | -- 51 | = ProductType 52 | -- | 53 | -- The constructor is for a type with multiple constructors 54 | -- 55 | | SumType 56 | 57 | derive instance eqConstructorType :: Eq ConstructorType 58 | derive instance ordConstructorType :: Ord ConstructorType 59 | 60 | instance showConstructorType :: Show ConstructorType where 61 | show ProductType = "ProductType" 62 | show SumType = "SumType" 63 | -------------------------------------------------------------------------------- /src/CoreFn/Binders.purs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The core functional representation for binders 3 | -- 4 | module CoreFn.Binders where 5 | 6 | import Prelude 7 | 8 | import CoreFn.Ident (Ident) 9 | import CoreFn.Literal (Literal) 10 | import CoreFn.Names (ProperName, Qualified) 11 | import Data.Array (intercalate) 12 | 13 | -- | 14 | -- Data type for binders 15 | -- 16 | data Binder a 17 | -- | 18 | -- Wildcard binder 19 | -- 20 | = NullBinder a 21 | -- | 22 | -- A binder which matches a literal value 23 | -- 24 | | LiteralBinder a (Literal (Binder a)) 25 | -- | 26 | -- A binder which binds an identifier 27 | -- 28 | | VarBinder a Ident 29 | -- | 30 | -- A binder which matches a data constructor 31 | -- 32 | | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) (Array (Binder a)) 33 | -- | 34 | -- A binder which binds its input to an identifier 35 | -- 36 | | NamedBinder a Ident (Binder a) 37 | 38 | derive instance eqBinder :: Eq a => Eq (Binder a) 39 | derive instance functorBinder :: Functor Binder 40 | derive instance ordBinder :: Ord a => Ord (Binder a) 41 | 42 | instance showBinder :: Show a => Show (Binder a) where 43 | show (NullBinder a) = "(NullBinder " <> show a <> ")" 44 | show (LiteralBinder a ls) = 45 | "(LiteralBinder " <> 46 | intercalate " " [ show a, show ls ] <> 47 | ")" 48 | show (VarBinder a i) = 49 | "(VarBinder " <> 50 | intercalate " " [ show a, show i ] <> 51 | ")" 52 | show (ConstructorBinder a t c bs) = 53 | "(ConstructorBinder " <> 54 | intercalate " " [ show a, show t, show c, show bs ] <> 55 | ")" 56 | show (NamedBinder a i b) = 57 | "(NamedBinder " <> 58 | intercalate " " [ show a, show i, show b ] <> 59 | ")" 60 | -------------------------------------------------------------------------------- /src/CoreFn/Names.purs: -------------------------------------------------------------------------------- 1 | module CoreFn.Names 2 | ( ModuleName(..) 3 | , OpName(..) 4 | , ProperName(..) 5 | , Qualified(..) 6 | ) where 7 | 8 | import Prelude 9 | 10 | import Data.Maybe (Maybe) 11 | import Data.Newtype (class Newtype, unwrap) 12 | 13 | -- | 14 | -- Module names 15 | -- 16 | newtype ModuleName = ModuleName (Array ProperName) 17 | 18 | derive instance eqModuleName :: Eq ModuleName 19 | derive instance newtypeModuleName :: Newtype ModuleName _ 20 | derive instance ordModuleName :: Ord ModuleName 21 | 22 | instance showModuleName :: Show ModuleName where 23 | show x = "(ModuleName " <> show (unwrap x) <> ")" 24 | 25 | 26 | -- | 27 | -- Operator alias names. 28 | -- 29 | newtype OpName = OpName String 30 | 31 | derive instance eqOpName :: Eq OpName 32 | derive instance newtypeOpName :: Newtype OpName _ 33 | derive instance ordOpName :: Ord OpName 34 | 35 | instance showOpName :: Show OpName where 36 | show x = "(OpName " <> show (unwrap x) <> ")" 37 | 38 | 39 | -- | 40 | -- Proper name, i.e. capitalized names for e.g. module names, type/data 41 | -- constructors. 42 | -- 43 | newtype ProperName = ProperName String 44 | 45 | derive instance eqProperName :: Eq ProperName 46 | derive instance newtypeProperName :: Newtype ProperName _ 47 | derive instance ordProperName :: Ord ProperName 48 | 49 | instance showProperName :: Show ProperName where 50 | show x = "(ProperName " <> show (unwrap x) <> ")" 51 | 52 | 53 | -- | 54 | -- A qualified name, i.e. a name with an optional module name 55 | -- 56 | data Qualified a = Qualified (Maybe ModuleName) a 57 | 58 | derive instance eqQualified :: Eq a => Eq (Qualified a) 59 | derive instance ordQualified :: Ord a => Ord (Qualified a) 60 | 61 | instance showQualified :: Show a => Show (Qualified a) where 62 | show (Qualified m a) = "(Qualified " <> show m <> " " <> show a <> ")" 63 | -------------------------------------------------------------------------------- /src/CoreFn/Module.purs: -------------------------------------------------------------------------------- 1 | module CoreFn.Module 2 | ( FilePath(..) 3 | , Module(..) 4 | , ModuleImport(..) 5 | , Version(..) 6 | ) where 7 | 8 | import Prelude 9 | 10 | import CoreFn.Ann (Comment, Ann) 11 | import CoreFn.Expr (Bind) 12 | import CoreFn.Ident (Ident) 13 | import CoreFn.Names (ModuleName) 14 | import Data.Newtype (class Newtype) 15 | 16 | -- | 17 | -- The CoreFn module representation 18 | -- 19 | newtype Module a = Module 20 | { moduleComments :: Array Comment 21 | , moduleName :: ModuleName 22 | , modulePath :: FilePath 23 | , moduleImports :: Array ModuleImport 24 | , moduleExports :: Array Ident 25 | , moduleForeign :: Array Ident 26 | , moduleDecls :: Array (Bind a) 27 | } 28 | 29 | derive instance newtypeModule :: Newtype (Module a) _ 30 | derive instance eqModule :: Eq a => Eq (Module a) 31 | derive instance ordModule :: Ord a => Ord (Module a) 32 | 33 | instance showModule :: Show a => Show (Module a) where 34 | show (Module m) = 35 | "(Module " <> 36 | "{ moduleComments: " <> show m.moduleComments <> 37 | ", moduleName: " <> show m.moduleName <> 38 | ", modulePath: " <> show m.modulePath <> 39 | ", moduleImports: " <> show m.moduleImports <> 40 | ", moduleExports: " <> show m.moduleExports <> 41 | ", moduleForeign: " <> show m.moduleForeign <> 42 | ", moduleDecls: " <> show m.moduleDecls <> " " <> 43 | "}" <> 44 | ")" 45 | 46 | 47 | newtype ModuleImport = ModuleImport 48 | { ann :: Ann 49 | , moduleName :: ModuleName 50 | } 51 | 52 | derive instance newtypeModuleImport :: Newtype ModuleImport _ 53 | derive instance eqModuleImport :: Eq ModuleImport 54 | derive instance ordModuleImport :: Ord ModuleImport 55 | 56 | instance showModuleImport :: Show ModuleImport where 57 | show (ModuleImport moduleImport) = 58 | "(ModuleImport " <> 59 | "{ ann: " <> show moduleImport.ann <> 60 | ", moduleName: " <> show moduleImport.moduleName <> " " <> 61 | "}" <> 62 | ")" 63 | 64 | 65 | newtype Version = Version String 66 | 67 | derive instance newtypeVersion :: Newtype Version _ 68 | derive newtype instance eqVersion :: Eq Version 69 | derive newtype instance ordVersion :: Ord Version 70 | 71 | instance showVersion :: Show Version where 72 | show (Version v) = "(Version " <> show v <> ")" 73 | 74 | 75 | newtype FilePath = FilePath String 76 | 77 | derive instance newtypeFilePath :: Newtype FilePath _ 78 | derive newtype instance eqFilePath :: Eq FilePath 79 | derive newtype instance ordFilePath :: Ord FilePath 80 | 81 | instance showFilePath :: Show FilePath where 82 | show (FilePath s) = "(FilePath " <> show s <> ")" 83 | -------------------------------------------------------------------------------- /src/CoreFn/Expr.purs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The core functional representation 3 | -- 4 | module CoreFn.Expr 5 | ( Bind(..) 6 | , CaseAlternative(..) 7 | , Expr(..) 8 | , Guard 9 | ) where 10 | 11 | import Prelude 12 | 13 | import CoreFn.Binders (Binder) 14 | import CoreFn.Ident (Ident) 15 | import CoreFn.Literal (Literal) 16 | import CoreFn.Names (ProperName, Qualified) 17 | import Data.Bifunctor (bimap, lmap) 18 | import Data.Either (Either(..), either) 19 | import Data.Profunctor.Strong ((***)) 20 | import Data.Traversable (intercalate) 21 | import Data.Tuple (Tuple) 22 | 23 | -- | 24 | -- Data type for expressions and terms 25 | -- 26 | data Expr a 27 | -- | 28 | -- A literal value 29 | -- 30 | = Literal a (Literal (Expr a)) 31 | -- | 32 | -- A data constructor (type name, constructor name, field names) 33 | -- 34 | | Constructor a ProperName ProperName (Array Ident) 35 | -- | 36 | -- A record property accessor 37 | -- 38 | | Accessor a String (Expr a) -- PSString 39 | -- | 40 | -- Partial record update 41 | -- 42 | | ObjectUpdate a (Expr a) (Array (Tuple String (Expr a))) -- PSString 43 | -- | 44 | -- Function introduction 45 | -- 46 | | Abs a Ident (Expr a) 47 | -- | 48 | -- Function application 49 | -- 50 | | App a (Expr a) (Expr a) 51 | -- | 52 | -- Variable 53 | -- 54 | | Var a (Qualified Ident) 55 | -- | 56 | -- A case expression 57 | -- 58 | | Case a (Array (Expr a)) (Array (CaseAlternative a)) 59 | -- | 60 | -- A let binding 61 | -- 62 | | Let a (Array (Bind a)) (Expr a) 63 | 64 | derive instance eqExpr :: Eq a => Eq (Expr a) 65 | derive instance functorExpr :: Functor Expr 66 | derive instance ordExpr :: Ord a => Ord (Expr a) 67 | 68 | instance showExpr :: Show a => Show (Expr a) where 69 | show (Literal a l) = 70 | "(Literal " <> 71 | intercalate " " [ show a, show l ] <> 72 | ")" 73 | show (Constructor a t c fs) = 74 | "(Constructor " <> 75 | intercalate " " [ show a, show t, show c, show fs] <> 76 | ")" 77 | show (Accessor a s e) = 78 | "(Accessor " <> 79 | intercalate " " [ show a, show s, show e ] <> 80 | ")" 81 | show (ObjectUpdate a e fs) = 82 | "(ObjectUpdate " <> 83 | intercalate " " [ show a, show e, show fs ] <> 84 | ")" 85 | show (Abs a i e) = 86 | "(Abs " <> 87 | intercalate " " [ show a, show i, show e ] <> 88 | ")" 89 | show (App a e1 e2) = 90 | "(App " <> 91 | intercalate " " [ show a, show e1, show e2 ] <> 92 | ")" 93 | show (Var a q) = 94 | "(Var " <> 95 | intercalate " " [ show a, show q ] <> 96 | ")" 97 | show (Case a es cs) = 98 | "(Case " <> 99 | intercalate " " [ show a, show es, show cs ] <> 100 | ")" 101 | show (Let a bs e) = 102 | "(Let " <> 103 | intercalate " " [ show a, show bs, show e ] <> 104 | ")" 105 | 106 | 107 | -- | 108 | -- A let or module binding. 109 | -- 110 | data Bind a 111 | = NonRec a Ident (Expr a) 112 | | Rec (Array (Tuple (Tuple a Ident) (Expr a))) 113 | 114 | derive instance eqBind :: Eq a => Eq (Bind a) 115 | derive instance ordBind :: Ord a => Ord (Bind a) 116 | 117 | instance functorBindRec :: Functor Bind where 118 | map f (NonRec a i e) = NonRec (f a) i (map f e) 119 | map f (Rec ts) = Rec $ map (bimap (lmap f) (map f)) ts 120 | 121 | instance showBind :: Show a => Show (Bind a) where 122 | show (NonRec a i e) = 123 | "(NonRec " <> 124 | intercalate " " [ show a, show i, show e ] <> 125 | ")" 126 | show (Rec b) = "(Rec " <> show b <> ")" 127 | 128 | 129 | -- | 130 | -- A guard is just a boolean-valued expression that appears alongside a set of binders 131 | -- 132 | type Guard a = Expr a 133 | 134 | 135 | -- | 136 | -- An alternative in a case statement 137 | -- 138 | data CaseAlternative a = CaseAlternative 139 | { 140 | -- | 141 | -- A collection of binders with which to match the inputs 142 | caseAlternativeBinders :: (Array (Binder a)) 143 | -- | 144 | -- The result expression or a collect of guarded expressions 145 | , caseAlternativeResult :: (Either (Array (Tuple (Guard a) (Expr a))) (Expr a)) 146 | } 147 | 148 | derive instance eqCaseAlternative :: Eq a => Eq (CaseAlternative a) 149 | derive instance ordCaseAlternative :: Ord a => Ord (CaseAlternative a) 150 | 151 | instance functorCaseAlternative :: Functor CaseAlternative where 152 | map f (CaseAlternative { caseAlternativeBinders, caseAlternativeResult }) = CaseAlternative 153 | { caseAlternativeBinders: (map (map f) caseAlternativeBinders) 154 | , caseAlternativeResult: (either (Left <<< map (map f *** map f)) (Right <<< map f) caseAlternativeResult) 155 | } 156 | 157 | instance showCaseAlternative :: Show a => Show (CaseAlternative a) where 158 | show (CaseAlternative { caseAlternativeBinders, caseAlternativeResult }) = 159 | "(CaseAlternative " <> 160 | "{ caseAlternativeBinders: " <> show caseAlternativeBinders <> 161 | ", caseAlternativeResult: " <> show caseAlternativeResult <> " " <> 162 | "}" <> 163 | ")" 164 | -------------------------------------------------------------------------------- /src/CoreFn/Ann.purs: -------------------------------------------------------------------------------- 1 | module CoreFn.Ann where 2 | 3 | import Prelude 4 | 5 | import CoreFn.Meta (Meta) 6 | import CoreFn.Names (OpName, ProperName, Qualified) 7 | import Data.Array as Array 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Newtype (class Newtype) 10 | 11 | -- | 12 | -- Type alias for basic annotations 13 | -- 14 | newtype Ann = Ann 15 | { sourceSpan :: SourceSpan 16 | , comments :: Array Comment 17 | , type :: Maybe Type 18 | , meta :: Maybe Meta 19 | } 20 | 21 | derive instance newtypeAnn :: Newtype Ann _ 22 | derive instance eqAnn :: Eq Ann 23 | derive instance ordAnn :: Ord Ann 24 | 25 | instance showAnn :: Show Ann where 26 | show (Ann ann) = 27 | "(Ann " <> 28 | "{ sourceSpan: " <> show ann.sourceSpan <> 29 | ", comments: " <> show ann.comments <> 30 | ", type: " <> show ann.type <> 31 | ", meta: " <> show ann.meta <> " " <> 32 | "}" <> 33 | ")" 34 | 35 | -- | 36 | -- An annotation empty of metadata aside from a source span. 37 | -- 38 | ssAnn :: SourceSpan -> Ann 39 | ssAnn = Ann <<< 40 | { sourceSpan: _ 41 | , comments: [] 42 | , type: Nothing 43 | , meta: Nothing 44 | } 45 | 46 | -- | 47 | -- Remove the comments from an annotation 48 | -- 49 | removeComments :: Ann -> Ann 50 | removeComments (Ann ann) = Ann $ ann { comments = [] } 51 | 52 | 53 | -- | 54 | -- Defines the types of source code comments 55 | -- 56 | data Comment 57 | = LineComment String 58 | | BlockComment String 59 | 60 | derive instance eqComment :: Eq Comment 61 | derive instance ordComment :: Ord Comment 62 | 63 | instance showComment :: Show Comment where 64 | show (LineComment s) = "(LineComment " <> show s <> ")" 65 | show (BlockComment s) = "(BlockComment " <> show s <> ")" 66 | 67 | 68 | -- | Source position information 69 | data SourcePos = SourcePos 70 | { sourcePosLine :: Int 71 | -- ^ Line number 72 | , sourcePosColumn :: Int 73 | -- ^ Column number 74 | } 75 | 76 | derive instance eqSourcePos :: Eq SourcePos 77 | derive instance ordSourcePos :: Ord SourcePos 78 | 79 | instance showSourcePos :: Show SourcePos where 80 | show (SourcePos { sourcePosLine, sourcePosColumn }) = 81 | "(SourcePos " <> 82 | "{ sourcePosLine: " <> show sourcePosLine <> 83 | ", sourcePosColumn: " <> show sourcePosColumn <> " " <> 84 | "}" <> 85 | ")" 86 | 87 | 88 | data SourceSpan = SourceSpan 89 | { spanName :: String 90 | -- ^ Source name 91 | , spanStart :: SourcePos 92 | -- ^ Start of the span 93 | , spanEnd :: SourcePos 94 | -- ^ End of the span 95 | } 96 | 97 | derive instance eqSourceSpan :: Eq SourceSpan 98 | derive instance ordSourceSpan :: Ord SourceSpan 99 | 100 | instance showSourceSpan :: Show SourceSpan where 101 | show (SourceSpan { spanName, spanStart, spanEnd }) = 102 | "(SourceSpan " <> 103 | "{ spanName: " <> show spanName <> 104 | ", spanStart: " <> show spanStart <> 105 | ", spanEnd: " <> show spanEnd <> " " <> 106 | "}" <> 107 | ")" 108 | 109 | 110 | -- | 111 | -- The type of types 112 | -- 113 | data Type 114 | -- | A unification variable of type Type 115 | = TUnknown Int 116 | -- | A named type variable 117 | | TypeVar String 118 | -- | A type-level string 119 | | TypeLevelString String -- PSString 120 | -- | A type wildcard, as would appear in a partial type synonym 121 | | TypeWildcard SourceSpan 122 | -- | A type constructor 123 | | TypeConstructor (Qualified ProperName) 124 | -- | A type operator. This will be desugared into a type constructor during the 125 | -- "operators" phase of desugaring. 126 | | TypeOp (Qualified OpName) 127 | -- | A type application 128 | | TypeApp Type Type 129 | -- | Forall quantifier 130 | | ForAll String Type (Maybe SkolemScope) 131 | -- | A type with a set of type class constraints 132 | | ConstrainedType Constraint Type 133 | -- | A skolem constant 134 | | Skolem String Int SkolemScope (Maybe SourceSpan) 135 | -- | An empty row 136 | | REmpty 137 | -- | A non-empty row 138 | | RCons Label Type Type 139 | -- | A type with a kind annotation 140 | | KindedType Type Kind 141 | -- | A placeholder used in pretty printing 142 | | PrettyPrintFunction Type Type 143 | -- | A placeholder used in pretty printing 144 | | PrettyPrintObject Type 145 | -- | A placeholder used in pretty printing 146 | | PrettyPrintForAll (Array String) Type 147 | -- | Binary operator application. During the rebracketing phase of desugaring, 148 | -- this data constructor will be removed. 149 | | BinaryNoParensType Type Type Type 150 | -- | Explicit parentheses. During the rebracketing phase of desugaring, this 151 | -- data constructor will be removed. 152 | -- 153 | -- Note: although it seems this constructor is not used, it _is_ useful, 154 | -- since it prevents certain traversals from matching. 155 | | ParensInType Type 156 | 157 | derive instance eqType :: Eq Type 158 | derive instance ordType :: Ord Type 159 | 160 | instance showType :: Show Type where 161 | show (TUnknown i) = "(TUnknown " <> show i <> ")" 162 | show (TypeVar s) = "(TypeVar " <> show s <> ")" 163 | show (TypeLevelString s) = "(TypeLevelString " <> show s <> ")" 164 | show (TypeWildcard so) = "(TypeWildcard " <> show so <> ")" 165 | show (TypeConstructor q) = "(TypeConstructor " <> show q <> ")" 166 | show (TypeOp q) = "(TypeOp " <> show q <> ")" 167 | show (TypeApp t1 t2) = "(TypeApp " <> show t1 <> " " <> show t2 <> ")" 168 | show (ForAll s t sk) = 169 | Array.intercalate " " 170 | [ "(Forall", show s, show t, show sk, ")"] 171 | show (ConstrainedType c t) = 172 | "(ConstrainedType " <> show c <> " " <> show t <> ")" 173 | show (Skolem s i sk ss) = 174 | Array.intercalate " " [ "(Skolem", show s, show i, show sk, show ss, ")" ] 175 | show REmpty = "Rempty" 176 | show (RCons l t1 t2) = 177 | Array.intercalate " " [ "(RCons", show l, show t1, show t2, ")" ] 178 | show (KindedType t k) = "(KindedType " <> show t <> show k <> ")" 179 | show (PrettyPrintFunction t1 t2) = 180 | "(PrettyPrintFunction " <> show t1 <> show t2 <> show ")" 181 | show (PrettyPrintObject t) = "(PrettyPrintObject " <> show t <> ")" 182 | show (PrettyPrintForAll ss t) = 183 | "(PrettyPrintForAll " <> show ss <> show t <> ")" 184 | show (BinaryNoParensType t1 t2 t3) = 185 | Array.intercalate " " 186 | [ "(BinaryNoParensType", show t1, show t2, show t3, ")" ] 187 | show (ParensInType t) = "(ParensInType " <> show t <> ")" 188 | 189 | -- | The data type of kinds 190 | data Kind 191 | -- | Unification variable of type Kind 192 | = KUnknown Int 193 | -- | Kinds for labelled, unordered rows without duplicates 194 | | Row Kind 195 | -- | Function kinds 196 | | FunKind Kind Kind 197 | -- | A named kind 198 | | NamedKind (Qualified ProperName) 199 | 200 | derive instance eqKind :: Eq Kind 201 | derive instance ordKind :: Ord Kind 202 | 203 | instance showKind :: Show Kind where 204 | show (KUnknown i) = "(KUnknown " <> show i <> ")" 205 | show (Row k) = "(Row " <> show k <> ")" 206 | show (FunKind k1 k2) = "(FunKind " <> show k1 <> show k2 <> ")" 207 | show (NamedKind q) = "(NamedKind " <> show q <> ")" 208 | 209 | 210 | -- | 211 | -- An identifier for the scope of a skolem variable 212 | -- 213 | newtype SkolemScope = SkolemScope Int 214 | 215 | derive newtype instance eqSkolemScope :: Eq SkolemScope 216 | derive newtype instance ordSkolemScope :: Ord SkolemScope 217 | 218 | instance showSkolemScope :: Show SkolemScope where 219 | show s = "(SkolemScope " <> show s <> ")" 220 | 221 | 222 | -- | Additional data relevant to type class constraints 223 | data ConstraintData 224 | = PartialConstraintData (Array (Array String)) Boolean 225 | -- ^ Data to accompany a Partial constraint generated by the exhaustivity checker. 226 | -- It contains (rendered) binder information for those binders which were 227 | -- not matched, and a flag indicating whether the list was truncated or not. 228 | -- Note: we use 'String' here because using 'Binder' would introduce a cyclic 229 | -- dependency in the module graph. 230 | 231 | derive instance eqConstraintData :: Eq ConstraintData 232 | derive instance ordConstraintData :: Ord ConstraintData 233 | 234 | instance showConstraintData :: Show ConstraintData where 235 | show (PartialConstraintData bs t) 236 | = "(PartialConstraintData " <> show bs <> " " <> show t <> ")" 237 | 238 | 239 | -- | A typeclass constraint 240 | data Constraint = Constraint 241 | { constraintClass :: Qualified ProperName 242 | -- ^ constraint class name 243 | , constraintArgs :: Array Type 244 | -- ^ type arguments 245 | , constraintData :: Maybe ConstraintData 246 | -- ^ additional data relevant to this constraint 247 | } 248 | 249 | derive instance eqConstraint :: Eq Constraint 250 | derive instance ordConstraint :: Ord Constraint 251 | 252 | instance showConstraint :: Show Constraint where 253 | show (Constraint { constraintClass, constraintArgs, constraintData }) = 254 | "(Constraint " <> 255 | "{ constraintClass: " <> show constraintClass <> 256 | ", constraintArgs: " <> show constraintArgs <> 257 | ", constraintData: " <> show constraintData <> " " <> 258 | "}" <> 259 | ")" 260 | 261 | 262 | -- | 263 | -- Labels are used as record keys and row entry names. Labels newtype PSString 264 | -- because records are indexable by PureScript strings at runtime. 265 | -- 266 | newtype Label = Label String -- PSString 267 | 268 | derive newtype instance eqLabel :: Eq Label 269 | derive newtype instance ordLabel :: Ord Label 270 | 271 | instance showLabel :: Show Label where 272 | show l = "(Label " <> show l <> ")" 273 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright 2016 Paul Young 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /src/CoreFn/FromJSON.purs: -------------------------------------------------------------------------------- 1 | module CoreFn.FromJSON 2 | ( moduleFromJSON 3 | ) where 4 | 5 | import Prelude 6 | 7 | import Control.Alt ((<|>)) 8 | import CoreFn.Ann (Ann(..), Comment(..), SourcePos(..), SourceSpan(..)) 9 | import CoreFn.Binders (Binder(..)) 10 | import CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..)) 11 | import CoreFn.Ident (Ident(..)) 12 | import CoreFn.Literal (Literal(..)) 13 | import CoreFn.Meta (ConstructorType(..), Meta(..)) 14 | import CoreFn.Module (FilePath(..), Module(..), ModuleImport(..), Version(..)) 15 | import CoreFn.Names (ModuleName(..), ProperName(..), Qualified(..)) 16 | import Data.Array as Array 17 | import Data.Either (Either(..)) 18 | import Foreign (F, Foreign, ForeignError(..), fail, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, typeOf) 19 | import Foreign.Index (index, readIndex, readProp) 20 | import Foreign.JSON (parseJSON) 21 | import Foreign.Keys (keys) 22 | import Data.Maybe (Maybe(..)) 23 | import Data.Newtype (unwrap) 24 | import Data.Traversable (traverse) 25 | import Data.Tuple (Tuple(..), uncurry) 26 | 27 | objectType :: String 28 | objectType = "object" 29 | 30 | object :: forall a. (Foreign -> F a) -> Foreign -> F a 31 | object _ json 32 | | typ <- typeOf json, typ /= objectType = fail $ TypeMismatch objectType typ 33 | object f json = f json 34 | 35 | constructorTypeFromJSON :: Foreign -> F ConstructorType 36 | constructorTypeFromJSON json = do 37 | type_ <- readString json 38 | case type_ of 39 | "ProductType" -> pure ProductType 40 | "SumType" -> pure SumType 41 | _ -> fail $ ForeignError $ "Unknown ConstructorType: " <> type_ 42 | 43 | metaFromJSON :: Foreign -> F Meta 44 | metaFromJSON = object $ \json -> do 45 | type_ <- readProp "metaType" json >>= readString 46 | case type_ of 47 | "IsConstructor" -> isConstructorFromJSON json 48 | "IsNewtype" -> pure IsNewtype 49 | "IsTypeClassConstructor" -> pure IsTypeClassConstructor 50 | "IsForeign" -> pure IsForeign 51 | "IsWhere" -> pure IsWhere 52 | _ -> fail $ ForeignError $ "Unknown Meta type :" <> type_ 53 | where 54 | isConstructorFromJSON :: Foreign -> F Meta 55 | isConstructorFromJSON json = do 56 | ct <- readProp "constructorType" json >>= constructorTypeFromJSON 57 | is <- readProp "identifiers" json >>= readArray >>= traverse identFromJSON 58 | pure $ IsConstructor ct is 59 | 60 | annFromJSON :: FilePath -> Foreign -> F Ann 61 | annFromJSON modulePath = object \json -> do 62 | sourceSpan <- readProp "sourceSpan" json >>= sourceSpanFromJSON 63 | meta <- readProp "meta" json >>= readNull >>= traverse metaFromJSON 64 | pure $ Ann { sourceSpan, comments: [], type: Nothing, meta } 65 | where 66 | sourceSpanFromJSON :: Foreign -> F SourceSpan 67 | sourceSpanFromJSON = object \json -> do 68 | spanStart <- readProp "start" json >>= sourcePosFromJSON 69 | spanEnd <- readProp "end" json >>= sourcePosFromJSON 70 | pure $ SourceSpan { spanName: unwrap modulePath, spanStart, spanEnd } 71 | 72 | sourcePosFromJSON :: Foreign -> F SourcePos 73 | sourcePosFromJSON json = do 74 | sourcePosLine <- index json 0 >>= readInt 75 | sourcePosColumn <- index json 1 >>= readInt 76 | pure $ SourcePos { sourcePosLine, sourcePosColumn } 77 | 78 | literalFromJSON :: forall a. (Foreign -> F a) -> Foreign -> F (Literal a) 79 | literalFromJSON t = object \json -> do 80 | type_ <- readProp "literalType" json >>= readString 81 | case type_ of 82 | "IntLiteral" -> 83 | NumericLiteral <<< Left <$> (readProp "value" json >>= readInt) 84 | "NumberLiteral" -> 85 | NumericLiteral <<< Right <$> (readProp "value" json >>= readNumber) 86 | "StringLiteral" -> 87 | StringLiteral <$> (readProp "value" json >>= readString) 88 | "CharLiteral" -> 89 | CharLiteral <$> (readProp "value" json >>= readChar) 90 | "BooleanLiteral" -> 91 | BooleanLiteral <$> (readProp "value" json >>= readBoolean) 92 | "ArrayLiteral" -> parseArrayLiteral json 93 | "ObjectLiteral" -> parseObjectLiteral json 94 | _ -> fail $ ForeignError $ "Unknown Literal: " <> type_ 95 | where 96 | parseArrayLiteral :: Foreign -> F (Literal a) 97 | parseArrayLiteral json = do 98 | val <- readProp "value" json >>= readArray 99 | as <- traverse t val 100 | pure $ ArrayLiteral as 101 | 102 | parseObjectLiteral :: Foreign -> F (Literal a) 103 | parseObjectLiteral json = do 104 | val <- readProp "value" json 105 | ObjectLiteral <$> recordFromJSON t val 106 | 107 | identFromJSON :: Foreign -> F Ident 108 | identFromJSON = map Ident <<< readString 109 | 110 | properNameFromJSON :: Foreign -> F ProperName 111 | properNameFromJSON = map ProperName <<< readString 112 | 113 | qualifiedFromJSON :: forall a. (String -> a) -> Foreign -> F (Qualified a) 114 | qualifiedFromJSON f = object \json -> do 115 | mn <- readProp "moduleName" json >>= readNull >>= traverse moduleNameFromJSON 116 | i <- readProp "identifier" json >>= map f <<< readString 117 | pure $ Qualified mn i 118 | 119 | moduleNameFromJSON :: Foreign -> F ModuleName 120 | moduleNameFromJSON json = map ModuleName $ readArray json 121 | >>= traverse properNameFromJSON 122 | 123 | moduleFromJSON :: String -> F { version :: Version, module :: Module Ann } 124 | moduleFromJSON = parseJSON >=> moduleFromJSON' 125 | where 126 | moduleFromJSON' :: Foreign -> F { version :: Version, module :: Module Ann } 127 | moduleFromJSON' = object \json -> do 128 | version <- map Version $ readProp "builtWith" json >>= readString 129 | 130 | moduleName <- readProp "moduleName" json >>= moduleNameFromJSON 131 | 132 | modulePath <- map FilePath $ readProp "modulePath" json >>= readString 133 | 134 | moduleImports <- readProp "imports" json 135 | >>= readArray 136 | >>= traverse (importFromJSON modulePath) 137 | 138 | moduleExports <- readProp "exports" json 139 | >>= readArray 140 | >>= traverse identFromJSON 141 | 142 | moduleDecls <- readProp "decls" json 143 | >>= readArray 144 | >>= traverse (bindFromJSON modulePath) 145 | 146 | moduleForeign <- readProp "foreign" json 147 | >>= readArray 148 | >>= traverse identFromJSON 149 | 150 | moduleComments <- readProp "comments" json 151 | >>= readArray 152 | >>= traverse commentFromJSON 153 | 154 | pure 155 | { version 156 | , module: Module 157 | { moduleComments 158 | , moduleName 159 | , modulePath 160 | , moduleImports 161 | , moduleExports 162 | , moduleForeign 163 | , moduleDecls 164 | } 165 | } 166 | 167 | importFromJSON 168 | :: FilePath 169 | -> Foreign 170 | -> F ModuleImport 171 | importFromJSON modulePath = object \json -> do 172 | ann <- readProp "annotation" json >>= annFromJSON modulePath 173 | moduleName <- readProp "moduleName" json >>= moduleNameFromJSON 174 | pure $ ModuleImport { ann, moduleName } 175 | 176 | commentFromJSON :: Foreign -> F Comment 177 | commentFromJSON json = 178 | lineCommentFromJSON json 179 | <|> blockCommentFromJSON json 180 | <|> invalidComment json 181 | where 182 | blockCommentFromJSON :: Foreign -> F Comment 183 | blockCommentFromJSON = 184 | readProp "BlockComment" >=> map BlockComment <<< readString 185 | 186 | lineCommentFromJSON :: Foreign -> F Comment 187 | lineCommentFromJSON = 188 | readProp "LineComment" >=> map LineComment <<< readString 189 | 190 | invalidComment :: Foreign -> F Comment 191 | invalidComment = keys >=> Array.head >>> case _ of 192 | Just type_ -> fail $ ForeignError $ "Unknown Comment type: " <> type_ 193 | Nothing -> fail $ ForeignError "Invalid Comment" 194 | 195 | bindFromJSON :: FilePath -> Foreign -> F (Bind Ann) 196 | bindFromJSON modulePath = object \json -> do 197 | type_ <- readProp "bindType" json >>= readString 198 | case type_ of 199 | "NonRec" -> (uncurry <<< uncurry) NonRec <$> bindFromJSON' json 200 | "Rec" -> 201 | map Rec 202 | $ readProp "binds" json 203 | >>= readArray 204 | >>= traverse (object bindFromJSON') 205 | _ -> fail $ ForeignError $ "Unknown Bind type: " <> type_ 206 | where 207 | bindFromJSON' :: Foreign -> F (Tuple (Tuple Ann Ident) (Expr Ann)) 208 | bindFromJSON' json = do 209 | ann <- readProp "annotation" json >>= annFromJSON modulePath 210 | ident <- readProp "identifier" json >>= identFromJSON 211 | expr <- readProp "expression" json >>= exprFromJSON modulePath 212 | pure $ Tuple (Tuple ann ident) expr 213 | 214 | recordFromJSON 215 | :: forall a 216 | . (Foreign -> F a) 217 | -> Foreign 218 | -> F (Array (Tuple String a)) 219 | recordFromJSON p json = readArray json >>= traverse parsePair 220 | where 221 | parsePair :: Foreign -> F (Tuple String a) 222 | parsePair v = do 223 | l <- readIndex 0 v >>= readString 224 | a <- readIndex 1 v >>= p 225 | pure $ Tuple l a 226 | 227 | exprFromJSON :: FilePath -> Foreign -> F (Expr Ann) 228 | exprFromJSON modulePath = object \json -> do 229 | type_ <- readProp "type" json >>= readString 230 | case type_ of 231 | "Var" -> varFromJSON json 232 | "Literal" -> literalExprFromJSON json 233 | "Constructor" -> constructorFromJSON json 234 | "Accessor" -> accessorFromJSON json 235 | "ObjectUpdate" -> objectUpdateFromJSON json 236 | "Abs" -> absFromJSON json 237 | "App" -> appFromJSON json 238 | "Case" -> caseFromJSON json 239 | "Let" -> letFromJSON json 240 | _ -> fail $ ForeignError $ "Unknown Expr type: " <> type_ 241 | where 242 | varFromJSON :: Foreign -> F (Expr Ann) 243 | varFromJSON json = do 244 | ann <- readProp "annotation" json >>= annFromJSON modulePath 245 | qi <- readProp "value" json >>= qualifiedFromJSON Ident 246 | pure $ Var ann qi 247 | 248 | literalExprFromJSON :: Foreign -> F (Expr Ann) 249 | literalExprFromJSON json = do 250 | ann <- readProp "annotation" json >>= annFromJSON modulePath 251 | lit <- readProp "value" json >>= literalFromJSON (exprFromJSON modulePath) 252 | pure $ Literal ann lit 253 | 254 | constructorFromJSON :: Foreign -> F (Expr Ann) 255 | constructorFromJSON json = do 256 | ann <- readProp "annotation" json >>= annFromJSON modulePath 257 | tyn <- readProp "typeName" json >>= properNameFromJSON 258 | con <- readProp "constructorName" json >>= properNameFromJSON 259 | is <- readProp "fieldNames" json >>= readArray >>= traverse identFromJSON 260 | pure $ Constructor ann tyn con is 261 | 262 | accessorFromJSON :: Foreign -> F (Expr Ann) 263 | accessorFromJSON json = do 264 | ann <- readProp "annotation" json >>= annFromJSON modulePath 265 | f <- readProp "fieldName" json >>= readString 266 | e <- readProp "expression" json >>= exprFromJSON modulePath 267 | pure $ Accessor ann f e 268 | 269 | objectUpdateFromJSON :: Foreign -> F (Expr Ann) 270 | objectUpdateFromJSON json = do 271 | ann <- readProp "annotation" json >>= annFromJSON modulePath 272 | e <- readProp "expression" json >>= exprFromJSON modulePath 273 | us <- readProp "updates" json >>= recordFromJSON (exprFromJSON modulePath) 274 | pure $ ObjectUpdate ann e us 275 | 276 | absFromJSON :: Foreign -> F (Expr Ann) 277 | absFromJSON json = do 278 | ann <- readProp "annotation" json >>= annFromJSON modulePath 279 | idn <- readProp "argument" json >>= identFromJSON 280 | e <- readProp "body" json >>= exprFromJSON modulePath 281 | pure $ Abs ann idn e 282 | 283 | appFromJSON :: Foreign -> F (Expr Ann) 284 | appFromJSON json = do 285 | ann <- readProp "annotation" json >>= annFromJSON modulePath 286 | e <- readProp "abstraction" json >>= exprFromJSON modulePath 287 | e' <- readProp "argument" json >>= exprFromJSON modulePath 288 | pure $ App ann e e' 289 | 290 | caseFromJSON :: Foreign -> F (Expr Ann) 291 | caseFromJSON json = do 292 | ann <- readProp "annotation" json >>= annFromJSON modulePath 293 | cs <- readProp "caseExpressions" json 294 | >>= readArray 295 | >>= traverse (exprFromJSON modulePath) 296 | cas <- readProp "caseAlternatives" json 297 | >>= readArray 298 | >>= traverse (caseAlternativeFromJSON modulePath) 299 | pure $ Case ann cs cas 300 | 301 | letFromJSON :: Foreign -> F (Expr Ann) 302 | letFromJSON json = do 303 | ann <- readProp "annotation" json >>= annFromJSON modulePath 304 | bs <- readProp "binds" json 305 | >>= readArray 306 | >>= traverse (bindFromJSON modulePath) 307 | e <- readProp "expression" json >>= exprFromJSON modulePath 308 | pure $ Let ann bs e 309 | 310 | caseAlternativeFromJSON :: FilePath -> Foreign -> F (CaseAlternative Ann) 311 | caseAlternativeFromJSON modulePath = object \json -> do 312 | bs <- readProp "binders" json 313 | >>= readArray 314 | >>= traverse (binderFromJSON modulePath) 315 | isGuarded <- readProp "isGuarded" json >>= readBoolean 316 | if isGuarded 317 | then do 318 | es <- readProp "expressions" json 319 | >>= readArray 320 | >>= traverse parseResultWithGuard 321 | pure $ CaseAlternative 322 | { caseAlternativeBinders: bs 323 | , caseAlternativeResult: Left es 324 | } 325 | else do 326 | e <- readProp "expression" json >>= exprFromJSON modulePath 327 | pure $ CaseAlternative 328 | { caseAlternativeBinders: bs 329 | , caseAlternativeResult: Right e 330 | } 331 | where 332 | parseResultWithGuard :: Foreign -> F (Tuple (Expr Ann) (Expr Ann)) 333 | parseResultWithGuard = object \json -> do 334 | g <- readProp "guard" json >>= exprFromJSON modulePath 335 | e <- readProp "expression" json >>= exprFromJSON modulePath 336 | pure $ Tuple g e 337 | 338 | binderFromJSON :: FilePath -> Foreign -> F (Binder Ann) 339 | binderFromJSON modulePath = object \json -> do 340 | type_ <- readProp "binderType" json >>= readString 341 | case type_ of 342 | "NullBinder" -> nullBinderFromJSON json 343 | "VarBinder" -> varBinderFromJSON json 344 | "LiteralBinder" -> literalBinderFromJSON json 345 | "ConstructorBinder" -> constructorBinderFromJSON json 346 | "NamedBinder" -> namedBinderFromJSON json 347 | _ -> fail $ ForeignError $ "Unknown Binder type: " <> type_ 348 | where 349 | nullBinderFromJSON :: Foreign -> F (Binder Ann) 350 | nullBinderFromJSON json = do 351 | ann <- readProp "annotation" json >>= annFromJSON modulePath 352 | pure $ NullBinder ann 353 | 354 | varBinderFromJSON :: Foreign -> F (Binder Ann) 355 | varBinderFromJSON json = do 356 | ann <- readProp "annotation" json >>= annFromJSON modulePath 357 | idn <- readProp "identifier" json >>= identFromJSON 358 | pure $ VarBinder ann idn 359 | 360 | literalBinderFromJSON :: Foreign -> F (Binder Ann) 361 | literalBinderFromJSON json = do 362 | ann <- readProp "annotation" json >>= annFromJSON modulePath 363 | lit <- readProp "literal" json 364 | >>= literalFromJSON (binderFromJSON modulePath) 365 | pure $ LiteralBinder ann lit 366 | 367 | constructorBinderFromJSON :: Foreign -> F (Binder Ann) 368 | constructorBinderFromJSON json = do 369 | ann <- readProp "annotation" json >>= annFromJSON modulePath 370 | tyn <- readProp "typeName" json >>= qualifiedFromJSON ProperName 371 | con <- readProp "constructorName" json >>= qualifiedFromJSON ProperName 372 | bs <- readProp "binders" json 373 | >>= readArray 374 | >>= traverse (binderFromJSON modulePath) 375 | pure $ ConstructorBinder ann tyn con bs 376 | 377 | namedBinderFromJSON :: Foreign -> F (Binder Ann) 378 | namedBinderFromJSON json = do 379 | ann <- readProp "annotation" json >>= annFromJSON modulePath 380 | n <- readProp "identifier" json >>= identFromJSON 381 | b <- readProp "binder" json >>= binderFromJSON modulePath 382 | pure $ NamedBinder ann n b 383 | -------------------------------------------------------------------------------- /test/CoreFn/FromJSON.purs: -------------------------------------------------------------------------------- 1 | module Test.CoreFn.FromJSON where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Except (runExcept) 6 | import CoreFn.Ann (SourcePos(..), SourceSpan(..), ssAnn) 7 | import CoreFn.FromJSON (moduleFromJSON) 8 | import CoreFn.Ident (Ident(..)) 9 | import CoreFn.Module (FilePath(..), ModuleImport(..)) 10 | import CoreFn.Names (ModuleName(..), ProperName(..)) 11 | import Data.Either (isRight) 12 | import Data.Newtype (unwrap) 13 | import Data.Traversable (traverse_) 14 | import Test.Spec (Spec, describe, it) 15 | import Test.Spec.Assertions (shouldEqual) 16 | 17 | spec :: Spec Unit 18 | spec = describe "FromJSON" do 19 | let 20 | mn = ModuleName [ ProperName "Example", ProperName "Main" ] 21 | mp = FilePath "src/Example/Main.purs" 22 | ss = SourceSpan 23 | { spanName: unwrap mp 24 | , spanStart: SourcePos { sourcePosLine: 0, sourcePosColumn: 0 } 25 | , spanEnd: SourcePos { sourcePosLine: 0, sourcePosColumn: 0 } 26 | } 27 | ann = ssAnn ss 28 | 29 | it "should parse an empty module" do 30 | let m = runExcept $ moduleFromJSON """ 31 | {"moduleName":["Example","Main"],"imports":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"moduleName":["Example","Main"]}],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[],"comments":[],"foreign":[]} 32 | """ 33 | isRight m `shouldEqual` true 34 | traverse_ (_.module >>> unwrap >>> _.moduleName >>> shouldEqual mn) m 35 | 36 | it "should parse module path" do 37 | let m = runExcept $ moduleFromJSON """ 38 | {"moduleName":["Example","Main"],"imports":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"moduleName":["Example","Main"]}],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[],"comments":[],"foreign":[]} 39 | """ 40 | isRight m `shouldEqual` true 41 | traverse_ (_.module >>> unwrap >>> _.modulePath >>> shouldEqual mp) m 42 | 43 | it "should parse imports" do 44 | let m = runExcept $ moduleFromJSON """ 45 | {"moduleName":["Example","Main"],"imports":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"moduleName":["Example","Main"]}],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[],"comments":[],"foreign":[]} 46 | """ 47 | isRight m `shouldEqual` true 48 | traverse_ (_.module >>> unwrap >>> _.moduleImports >>> shouldEqual [ ModuleImport { ann, moduleName: mn } ]) m 49 | 50 | it "should parse exports" do 51 | let m = runExcept $ moduleFromJSON """ 52 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":["exp"],"decls":[],"comments":[],"foreign":[]} 53 | """ 54 | isRight m `shouldEqual` true 55 | traverse_ (_.module >>> unwrap >>> _.moduleExports >>> shouldEqual [ Ident "exp" ]) m 56 | 57 | it "should parse foreign" do 58 | let m = runExcept $ moduleFromJSON """ 59 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[],"comments":[],"foreign":["exp"]} 60 | """ 61 | isRight m `shouldEqual` true 62 | traverse_ (_.module >>> unwrap >>> _.moduleForeign >>> shouldEqual [ Ident "exp" ]) m 63 | 64 | describe "Expr" do 65 | it "should parse literals" do 66 | let m = runExcept $ moduleFromJSON """ 67 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"x1","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"IntLiteral","value":1},"type":"Literal"},"bindType":"NonRec"},{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"x2","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"NumberLiteral","value":1},"type":"Literal"},"bindType":"NonRec"},{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"x3","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"StringLiteral","value":"abc"},"type":"Literal"},"bindType":"NonRec"},{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"x4","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"c"},"type":"Literal"},"bindType":"NonRec"},{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"x5","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"BooleanLiteral","value":true},"type":"Literal"},"bindType":"NonRec"},{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"x6","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"ArrayLiteral","value":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"a"},"type":"Literal"}]},"type":"Literal"},"bindType":"NonRec"},{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"x7","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"ObjectLiteral","value":[["a",{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"a"},"type":"Literal"}]]},"type":"Literal"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 68 | """ 69 | isRight m `shouldEqual` true 70 | 71 | it "should parse Constructor" do 72 | let m = runExcept $ moduleFromJSON """ 73 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"constructor","expression":{"constructorName":"Left","annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"typeName":"Either","fieldNames":["value0"],"type":"Constructor"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 74 | """ 75 | isRight m `shouldEqual` true 76 | 77 | it "should parse Accessor" do 78 | let m = runExcept $ moduleFromJSON """ 79 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"x","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"ObjectLiteral","value":[["field",{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"IntLiteral","value":1},"type":"Literal"}]]},"type":"Literal"},"fieldName":"field","type":"Accessor"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 80 | """ 81 | isRight m `shouldEqual` true 82 | 83 | it "should parse ObjectUpdate" do 84 | let m = runExcept $ moduleFromJSON """ 85 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"objectUpdate","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"ObjectLiteral","value":[["field",{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"StringLiteral","value":"abc"},"type":"Literal"}]]},"type":"Literal"},"updates":[["field",{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"StringLiteral","value":"xyz"},"type":"Literal"}]],"type":"ObjectUpdate"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 86 | """ 87 | isRight m `shouldEqual` true 88 | 89 | it "should parse Abs" do 90 | let m = runExcept $ moduleFromJSON """ 91 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"abs","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"body":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"moduleName":["Example","Main"],"identifier":"x"},"type":"Var"},"argument":"x","type":"Abs"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 92 | """ 93 | isRight m `shouldEqual` true 94 | 95 | it "should parse App" do 96 | let m = runExcept $ moduleFromJSON """ 97 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"app","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"c"},"type":"Literal"},"type":"App","abstraction":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"body":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"moduleName":null,"identifier":"x"},"type":"Var"},"argument":"x","type":"Abs"}},"bindType":"NonRec"}],"comments":[],"foreign":[]} 98 | """ 99 | isRight m `shouldEqual` true 100 | 101 | it "should parse Case" do 102 | let m = runExcept $ moduleFromJSON """ 103 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"case","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"moduleName":null,"identifier":"x"},"type":"Var"}],"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"binderType":"NullBinder"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"a"},"type":"Literal"},"isGuarded":false}],"type":"Case"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 104 | """ 105 | isRight m `shouldEqual` true 106 | 107 | it "should parse Case with guards" do 108 | let m = runExcept $ moduleFromJSON """ 109 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"case","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"moduleName":null,"identifier":"x"},"type":"Var"}],"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"binderType":"NullBinder"}],"expressions":[{"guard":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"BooleanLiteral","value":true},"type":"Literal"},"expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"a"},"type":"Literal"}}],"isGuarded":true}],"type":"Case"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 110 | """ 111 | isRight m `shouldEqual` true 112 | 113 | it "should parse Let" do 114 | let m = runExcept $ moduleFromJSON """ 115 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"case","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"binds":[{"binds":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"a","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"moduleName":null,"identifier":"x"},"type":"Var"}}],"bindType":"Rec"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"BooleanLiteral","value":true},"type":"Literal"},"type":"Let"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 116 | """ 117 | isRight m `shouldEqual` true 118 | 119 | describe "Meta" do 120 | it "should parse IsConstructor" do 121 | let m = runExcept $ moduleFromJSON """ 122 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":{"metaType":"IsConstructor","identifiers":["x"],"constructorType":"ProductType"},"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"x","expression":{"annotation":{"meta":{"metaType":"IsConstructor","identifiers":[],"constructorType":"SumType"},"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"a"},"type":"Literal"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 123 | """ 124 | isRight m `shouldEqual` true 125 | 126 | it "should parse IsNewtype" do 127 | let m = runExcept $ moduleFromJSON """ 128 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":{"metaType":"IsNewtype"},"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"x","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"a"},"type":"Literal"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 129 | """ 130 | isRight m `shouldEqual` true 131 | 132 | it "should parse IsTypeClassConstructor" do 133 | let m = runExcept $ moduleFromJSON """ 134 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":{"metaType":"IsTypeClassConstructor"},"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"x","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"a"},"type":"Literal"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 135 | """ 136 | isRight m `shouldEqual` true 137 | 138 | it "should parse IsForeign" do 139 | let m = runExcept $ moduleFromJSON """ 140 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"x","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"a"},"type":"Literal"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 141 | """ 142 | isRight m `shouldEqual` true 143 | 144 | describe "Binders" do 145 | it "should parse LiteralBinder" do 146 | let m = runExcept $ moduleFromJSON """ 147 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"case","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"moduleName":null,"identifier":"x"},"type":"Var"}],"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"literal":{"literalType":"BooleanLiteral","value":true},"binderType":"LiteralBinder"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"a"},"type":"Literal"},"isGuarded":false}],"type":"Case"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 148 | """ 149 | isRight m `shouldEqual` true 150 | 151 | it "should parse VarBinder" do 152 | let m = runExcept $ moduleFromJSON """ 153 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"case","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"moduleName":null,"identifier":"x"},"type":"Var"}],"caseAlternatives":[{"binders":[{"constructorName":{"moduleName":null,"identifier":"Left"},"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"typeName":{"moduleName":["Data","Either"],"identifier":"Either"},"binders":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"z","binderType":"VarBinder"}],"binderType":"ConstructorBinder"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"a"},"type":"Literal"},"isGuarded":false}],"type":"Case"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 154 | """ 155 | isRight m `shouldEqual` true 156 | 157 | it "should parse NamedBinder" do 158 | let m = runExcept $ moduleFromJSON """ 159 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"case","expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"moduleName":null,"identifier":"x"},"type":"Var"}],"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"w","binder":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"w'","binder":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"identifier":"w''","binderType":"VarBinder"},"binderType":"NamedBinder"},"binderType":"NamedBinder"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"start":[0,0],"end":[0,0]}},"value":{"literalType":"CharLiteral","value":"a"},"type":"Literal"},"isGuarded":false}],"type":"Case"},"bindType":"NonRec"}],"comments":[],"foreign":[]} 160 | """ 161 | isRight m `shouldEqual` true 162 | 163 | describe "Comments" do 164 | it "should parse LineComment" do 165 | let m = runExcept $ moduleFromJSON """ 166 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[],"comments":[{"LineComment":"line"}],"foreign":[]} 167 | """ 168 | isRight m `shouldEqual` true 169 | 170 | it "should parse BlockComment" do 171 | let m = runExcept $ moduleFromJSON """ 172 | {"moduleName":["Example","Main"],"imports":[],"builtWith":"0","modulePath":"src/Example/Main.purs","exports":[],"decls":[],"comments":[{"BlockComment":"block"}],"foreign":[]} 173 | """ 174 | isRight m `shouldEqual` true 175 | --------------------------------------------------------------------------------