diff --git a/ats-format.cabal b/ats-format.cabal --- a/ats-format.cabal +++ b/ats-format.cabal @@ -1,5 +1,5 @@ name: ats-format -version: 0.1.0.18 +version: 0.1.0.19 synopsis: A source-code formatter for ATS description: An opinionated source-code formatter for ATS (http://www.ats-lang.org/). homepage: https://hub.darcs.net/vmchale/ats-format#readme diff --git a/src/Language/ATS.hs b/src/Language/ATS.hs --- a/src/Language/ATS.hs +++ b/src/Language/ATS.hs @@ -17,6 +17,7 @@ , UnOp (..) , BinOp (..) , DataPropLeaf (..) + , Leaf (..) , Arg (..) , Addendum (..) , LambdaType (..) diff --git a/src/Language/ATS/Parser.y b/src/Language/ATS/Parser.y --- a/src/Language/ATS/Parser.y +++ b/src/Language/ATS/Parser.y @@ -451,20 +451,21 @@ IdentifiersIn : identifier { [$1] } | IdentifiersIn comma identifier { $3 : $1 } +OfType : { Nothing } + | of Type { Just $2 } + -- | Parse a constructor for a sum type -SumLeaf : vbar identifier { ($2, [], Nothing) } - | vbar identifierSpace of Type { ($2, [], Just $4) } - | vbar IdentifierOr openParen IdentifiersIn closeParen { ($2, $4, Nothing) } - | vbar IdentifierOr openParen IdentifiersIn closeParen of Type { ($2, $4, Just $7) } +SumLeaf : vbar Universals identifier { Leaf $2 $3 [] Nothing } + | vbar Universals identifierSpace of Type { Leaf $2 $3 [] (Just $5) } + | vbar Universals IdentifierOr openParen IdentifiersIn closeParen OfType { Leaf $2 $3 $5 $7 } -- | Parse all constructors of a sum type Leaves : SumLeaf { [$1] } | Leaves SumLeaf { $2 : $1 } - | identifierSpace of Type { [($1, [], Just $3)] } - | identifier { [($1, [], Nothing)] } + | Universals identifierSpace of Type { [Leaf $1 $2 [] (Just $4)] } + | Universals identifier { [Leaf $1 $2 [] Nothing] } + | Universals identifier openParen IdentifiersIn closeParen OfType { [Leaf $1 $2 $4 $6] } | dollar {% Left $ Expected $1 "|" "$" } - | identifier openParen IdentifiersIn closeParen { [($1, $3, Nothing)] } - | identifier openParen IdentifiersIn closeParen of Type { [($1, $3, Just $6)] } Universals : { [] } | doubleBraces { [] } @@ -589,6 +590,7 @@ Declaration : include string { Include $2 } | define { Define $1 } | define identifierSpace string { Define ($1 ++ $2 ++ $3) } -- FIXME better approach? + | define identifierSpace int { Define ($1 ++ $2 ++ " " ++ show $3) } | cblock { CBlock $1 } | lineComment { Comment $1 } | staload underscore eq string { Staload (Just "_") $4 } diff --git a/src/Language/ATS/PrettyPrint.hs b/src/Language/ATS/PrettyPrint.hs --- a/src/Language/ATS/PrettyPrint.hs +++ b/src/Language/ATS/PrettyPrint.hs @@ -236,39 +236,39 @@ instance Pretty Type where pretty = cata a where - a IntF = "int" - a StringF = "string" - a BoolF = "bool" - a VoidF = "void" - a NatF = "nat" - a AddrF = "addr" - a CharF = "char" - a (NamedF n) = string n - a (ExF e t) = pretty e <+> t - a (DependentIntF e) = "int(" <> pretty e <> ")" - a (DependentBoolF e) = "bool(" <> pretty e <> ")" - a (DepStringF e) = "string(" <> pretty e <> ")" - a (DependentF n ts) = pretty n <> parens (mconcat (punctuate ", " (fmap pretty (reverse ts)))) - a DoubleF = "double" - a FloatF = "float" - a (ForAF u t) = pretty u <+> t - a (UnconsumedF t) = "!" <> t + a IntF = "int" + a StringF = "string" + a BoolF = "bool" + a VoidF = "void" + a NatF = "nat" + a AddrF = "addr" + a CharF = "char" + a (NamedF n) = string n + a (ExF e t) = pretty e <+> t + a (DependentIntF e) = "int(" <> pretty e <> ")" + a (DependentBoolF e) = "bool(" <> pretty e <> ")" + a (DepStringF e) = "string(" <> pretty e <> ")" + a (DependentF n ts) = pretty n <> parens (mconcat (punctuate ", " (fmap pretty (reverse ts)))) + a DoubleF = "double" + a FloatF = "float" + a (ForAF u t) = pretty u <+> t + a (UnconsumedF t) = "!" <> t a (AsProofF t (Just t')) = t <+> ">>" <+> t' - a (AsProofF t Nothing) = t <+> ">> _" - a (FromVTF t) = t <> "?!" - a (MaybeValF t) = t <> "?" - a (T0pF ad) = "t@ype" <> pretty ad - a (Vt0pF ad) = "vt@ype" <> pretty ad - a (AtF _ t t') = t <+> "@" <+> t' - a (ProofTypeF _ t t') = parens (t <+> "|" <+> t') - a (ConcreteTypeF e) = pretty e - a (TupleF _ ts) = parens (mconcat (punctuate ", " (fmap pretty (reverse ts)))) - a (RefTypeF t) = "&" <> t - a (ViewTypeF _ t) = "view@" <> parens t + a (AsProofF t Nothing) = t <+> ">> _" + a (FromVTF t) = t <> "?!" + a (MaybeValF t) = t <> "?" + a (T0pF ad) = "t@ype" <> pretty ad + a (Vt0pF ad) = "vt@ype" <> pretty ad + a (AtF _ t t') = t <+> "@" <+> t' + a (ProofTypeF _ t t') = parens (t <+> "|" <+> t') + a (ConcreteTypeF e) = pretty e + a (TupleF _ ts) = parens (mconcat (punctuate ", " (fmap pretty (reverse ts)))) + a (RefTypeF t) = "&" <> t + a (ViewTypeF _ t) = "view@" <> parens t a (FunctionTypeF s t t') = t <+> string s <+> t' - a (ViewLiteralF c) = "view" <> pretty c - a NoneTypeF{} = "()" - a ImplicitTypeF{} = ".." + a (ViewLiteralF c) = "view" <> pretty c + a NoneTypeF{} = "()" + a ImplicitTypeF{} = ".." gan :: Maybe Type -> Doc gan (Just t) = " : " <> pretty t <> " " @@ -336,37 +336,48 @@ prettyRecord es = group (flatAlt (prettyRecordF True es) (prettyRecordS True es)) prettyRecordS :: (Pretty a) => Bool -> [(String, a)] -> Doc -prettyRecordS _ [] = mempty -prettyRecordS True [(s, t)] = "@{" <+> string s <+> "=" <+> pretty t <+> "}" -prettyRecordS _ [(s, t)] = "@{" <+> string s <+> "=" <+> pretty t +prettyRecordS _ [] = mempty +prettyRecordS True [(s, t)] = "@{" <+> string s <+> "=" <+> pretty t <+> "}" +prettyRecordS _ [(s, t)] = "@{" <+> string s <+> "=" <+> pretty t prettyRecordS True ((s, t):xs) = prettyRecordS False xs <> ("," <+> string s <+> "=" <+> pretty t <+> "}") -prettyRecordS x ((s, t):xs) = prettyRecordS x xs <> ("," <+> string s <+> "=" <+> pretty t) +prettyRecordS x ((s, t):xs) = prettyRecordS x xs <> ("," <+> string s <+> "=" <+> pretty t) prettyRecordF :: (Pretty a) => Bool -> [(String, a)] -> Doc -prettyRecordF _ [] = mempty -prettyRecordF True [(s, t)] = "@{" <+> string s <+> "=" <+> pretty t <+> "}" -prettyRecordF _ [(s, t)] = "@{" <+> string s <+> "=" <+> pretty t +prettyRecordF _ [] = mempty +prettyRecordF True [(s, t)] = "@{" <+> string s <+> "=" <+> pretty t <+> "}" +prettyRecordF _ [(s, t)] = "@{" <+> string s <+> "=" <+> pretty t prettyRecordF True ((s, t):xs) = prettyRecordF False xs $$ indent 1 ("," <+> string s <+> "=" <+> pretty t <$> "}") -prettyRecordF x ((s, t):xs) = prettyRecordF x xs $$ indent 1 ("," <+> string s <+> "=" <+> pretty t) +prettyRecordF x ((s, t):xs) = prettyRecordF x xs $$ indent 1 ("," <+> string s <+> "=" <+> pretty t) prettyDL :: [DataPropLeaf] -> Doc -prettyDL [] = mempty -prettyDL [DataPropLeaf us e Nothing] = indent 2 ("|" <+> foldMap pretty us <+> pretty e) +prettyDL [] = mempty +prettyDL [DataPropLeaf us e Nothing] = indent 2 ("|" <+> foldMap pretty us <+> pretty e) prettyDL [DataPropLeaf us e (Just e')] = indent 2 ("|" <+> foldMap pretty us <+> pretty e <+> "of" <+> pretty e') -prettyDL (DataPropLeaf us e Nothing:xs) = prettyDL xs $$ indent 2 ("|" <+> foldMap pretty us <+> pretty e) +prettyDL (DataPropLeaf us e Nothing:xs) = prettyDL xs $$ indent 2 ("|" <+> foldMap pretty us <+> pretty e) prettyDL (DataPropLeaf us e (Just e'):xs) = prettyDL xs $$ indent 2 ("|" <+> foldMap pretty us <+> pretty e <+> "of" <+> pretty e') -prettyLeaf :: [(String, [String], Maybe Type)] -> Doc -prettyLeaf [] = mempty -prettyLeaf [(s, [], Nothing)] = indent 2 ("|" <+> string s) -prettyLeaf [(s, [], Just e)] = indent 2 ("|" <+> string s <+> "of" <+> pretty e) -prettyLeaf ((s, [], Nothing):xs) = prettyLeaf xs $$ indent 2 ("|" <+> string s) -prettyLeaf ((s, [], Just e):xs) = prettyLeaf xs $$ indent 2 ("|" <+> string s <+> "of" <+> pretty e) -prettyLeaf [(s, as, Nothing)] = indent 2 ("|" <+> string s <> prettyArgs as) -prettyLeaf [(s, as, Just e)] = indent 2 ("|" <+> string s <> prettyArgs as <+> "of" <+> pretty e) -prettyLeaf ((s, as, Nothing):xs) = prettyLeaf xs $$ indent 2 ("|" <+> string s <> prettyArgs as) -prettyLeaf ((s, as, Just e):xs) = prettyLeaf xs $$ indent 2 ("|" <+> string s <> prettyArgs as <+> "of" <+> pretty e) +universalHelper :: [Universal] -> Doc +universalHelper = mconcat . fmap pretty . reverse +prettyLeaf :: [Leaf] -> Doc +prettyLeaf [] = mempty +prettyLeaf [Leaf [] s [] Nothing] = indent 2 ("|" <+> string s) +prettyLeaf [Leaf [] s [] (Just e)] = indent 2 ("|" <+> string s <+> "of" <+> pretty e) +prettyLeaf (Leaf [] s [] Nothing:xs) = prettyLeaf xs $$ indent 2 ("|" <+> string s) +prettyLeaf (Leaf [] s [] (Just e):xs) = prettyLeaf xs $$ indent 2 ("|" <+> string s <+> "of" <+> pretty e) +prettyLeaf [Leaf [] s as Nothing] = indent 2 ("|" <+> string s <> prettyArgs as) +prettyLeaf [Leaf [] s as (Just e)] = indent 2 ("|" <+> string s <> prettyArgs as <+> "of" <+> pretty e) +prettyLeaf (Leaf [] s as Nothing:xs) = prettyLeaf xs $$ indent 2 ("|" <+> string s <> prettyArgs as) +prettyLeaf (Leaf [] s as (Just e):xs) = prettyLeaf xs $$ indent 2 ("|" <+> string s <> prettyArgs as <+> "of" <+> pretty e) +prettyLeaf [Leaf us s [] Nothing] = indent 2 ("|" <+> universalHelper us <+> string s) +prettyLeaf [Leaf us s [] (Just e)] = indent 2 ("|" <+> universalHelper us <+> string s <+> "of" <+> pretty e) +prettyLeaf (Leaf us s [] Nothing:xs) = prettyLeaf xs $$ indent 2 ("|" <+> universalHelper us <+> string s) +prettyLeaf (Leaf us s [] (Just e):xs) = prettyLeaf xs $$ indent 2 ("|" <+> universalHelper us <+> string s <+> "of" <+> pretty e) +prettyLeaf [Leaf us s as Nothing] = indent 2 ("|" <+> universalHelper us <+> string s <> prettyArgs as) +prettyLeaf [Leaf us s as (Just e)] = indent 2 ("|" <+> universalHelper us <+> string s <> prettyArgs as <+> "of" <+> pretty e) +prettyLeaf (Leaf us s as Nothing:xs) = prettyLeaf xs $$ indent 2 ("|" <+> universalHelper us <+> string s <> prettyArgs as) +prettyLeaf (Leaf us s as (Just e):xs) = prettyLeaf xs $$ indent 2 ("|" <+> universalHelper us <+> string s <> prettyArgs as <+> "of" <+> pretty e) + prettyHelper :: Doc -> [Doc] -> [Doc] prettyHelper _ [x] = [x] prettyHelper c (x:xs) = flatAlt (" " <> x) x : fmap (c <>) xs @@ -417,56 +428,56 @@ pretty _ = "FIXME" instance Pretty DataPropLeaf where - pretty (DataPropLeaf us e Nothing) = "|" <+> foldMap pretty (reverse us) <+> pretty e + pretty (DataPropLeaf us e Nothing) = "|" <+> foldMap pretty (reverse us) <+> pretty e pretty (DataPropLeaf us e (Just e')) = "|" <+> foldMap pretty (reverse us) <+> pretty e <+> "of" <+> pretty e' typeHelper :: [(String, Type)] -> Doc typeHelper rs = group (flatAlt ("=" <$> indent 2 (prettyRecord rs)) ("=" <+> prettyRecord rs)) instance Pretty Declaration where - pretty (AbsType _ s as Nothing) = "abstype" <+> string s <> prettyArgs as + pretty (AbsType _ s as Nothing) = "abstype" <+> string s <> prettyArgs as pretty (AbsViewType _ s as Nothing) = "absvtype" <+> string s <> prettyArgs as - pretty (RecordType s [] [] rs) = "typedef" <+> string s <+> "=" <+> prettyRecord rs - pretty (RecordType s as [] rs) = "typedef" <+> string s <> prettyArgs as <+> "=" <+> prettyRecord rs - pretty (RecordViewType s [] [] rs) = "vtypedef" <+> string s <+> "=" prettyRecord rs - pretty (RecordViewType s as [] rs) = "vtypedef" <+> string s <> prettyArgs as <+> typeHelper rs - pretty (RecordViewType s as us rs) = "vtypedef" <+> string s <> prettyArgs as <+> "=" fancyU us prettyRecord rs - pretty (SumViewType s [] ls) = "datavtype" <+> string s <+> "=" <$> prettyLeaf ls - pretty (SumViewType s as ls) = "datavtype" <+> string s <> prettyArgs as <+> "=" <$> prettyLeaf ls - pretty (SumType s [] ls) = "datatype" <+> string s <+> "=" <$> prettyLeaf ls - pretty (SumType s as ls) = "datatype" <+> string s <> prettyArgs as <+> "=" <$> prettyLeaf ls - pretty (Impl [] i) = pretty i - pretty (PrVal p e) = "prval" <+> pretty p <+> "=" <+> pretty e - pretty (Val a Nothing p e) = "val" <> pretty a <+> pretty p <+> "=" <+> pretty e - pretty (Val a (Just t) p e) = "val" <> pretty a <+> pretty p <> ":" <+> pretty t <+> "=" <+> pretty e - pretty (Var (Just t) p Nothing e) = "var" <+> pretty p <> ":" <+> pretty t <+> "with" <+> pretty e - pretty (Var Nothing p e Nothing) = "var" <+> pretty p <+> "=" <+> pretty e - pretty (Var (Just t) p e Nothing) = "var" <+> pretty p <> ":" <+> pretty t <+> "=" <+> pretty e - pretty (Include s) = "#include" <+> pretty s - pretty (Staload Nothing s) = "staload" <+> pretty s - pretty (Staload (Just q) s) = "staload" <+> pretty q <+> "=" <+> pretty s - pretty (CBlock s) = string s - pretty (Comment s) = string s - pretty (OverloadOp _ o n) = "overload" <+> pretty o <+> "with" <+> pretty n - pretty (OverloadIdent _ i n) = "overload" <+> string i <+> "with" <+> pretty n - pretty (Func _ (Fn pref)) = "fn" pretty pref - pretty (Func _ (Fun pref)) = "fun" pretty pref - pretty (Func _ (CastFn pref)) = "castfn" pretty pref - pretty (Func _ (Fnx pref)) = "fnx" pretty pref - pretty (Func _ (And pref)) = "and" pretty pref - pretty (Func _ (Praxi pref)) = "praxi" pretty pref - pretty (Func _ (PrFun pref)) = "prfun" pretty pref - pretty (Func _ (PrFn pref)) = "prfn" pretty pref - pretty (Extern _ d) = "extern" <$> pretty d - pretty (Define s) = string s - pretty (DataProp _ s as ls) = "dataprop" <+> string s <> prettyArgs as <+> "=" <$> prettyDL ls - pretty (ViewTypeDef _ s [] t) = "vtypedef" <+> string s <+> "=" pretty t - pretty (ViewTypeDef _ s as t) = "vtypedef" <+> string s <> prettyArgs as <+> "=" pretty t - pretty (TypeDef _ s [] t) = "typedef" <+> string s <+> "=" <+> pretty t - pretty (TypeDef _ s as t) = "typedef" <+> string s <> prettyArgs as <+> "=" <+> pretty t - pretty (AbsProp _ n as) = "absprop" <+> string n <+> prettyArgs as - pretty (Assume n as e) = "assume" pretty n <> prettyArgs as <+> "=" pretty e - pretty (SymIntr _ n) = "symintr" <+> pretty n - pretty (Stacst _ n t Nothing) = "stacst" pretty n <+> ":" pretty t - pretty (Stacst _ n t (Just e)) = "stacst" pretty n <+> ":" pretty t <+> "=" pretty e - pretty _ = "FIXME" + pretty (RecordType s [] [] rs) = "typedef" <+> string s <+> "=" <+> prettyRecord rs + pretty (RecordType s as [] rs) = "typedef" <+> string s <> prettyArgs as <+> "=" <+> prettyRecord rs + pretty (RecordViewType s [] [] rs) = "vtypedef" <+> string s <+> "=" prettyRecord rs + pretty (RecordViewType s as [] rs) = "vtypedef" <+> string s <> prettyArgs as <+> typeHelper rs + pretty (RecordViewType s as us rs) = "vtypedef" <+> string s <> prettyArgs as <+> "=" fancyU us prettyRecord rs + pretty (SumViewType s [] ls) = "datavtype" <+> string s <+> "=" <$> prettyLeaf ls + pretty (SumViewType s as ls) = "datavtype" <+> string s <> prettyArgs as <+> "=" <$> prettyLeaf ls + pretty (SumType s [] ls) = "datatype" <+> string s <+> "=" <$> prettyLeaf ls + pretty (SumType s as ls) = "datatype" <+> string s <> prettyArgs as <+> "=" <$> prettyLeaf ls + pretty (Impl [] i) = pretty i + pretty (PrVal p e) = "prval" <+> pretty p <+> "=" <+> pretty e + pretty (Val a Nothing p e) = "val" <> pretty a <+> pretty p <+> "=" <+> pretty e + pretty (Val a (Just t) p e) = "val" <> pretty a <+> pretty p <> ":" <+> pretty t <+> "=" <+> pretty e + pretty (Var (Just t) p Nothing e) = "var" <+> pretty p <> ":" <+> pretty t <+> "with" <+> pretty e + pretty (Var Nothing p e Nothing) = "var" <+> pretty p <+> "=" <+> pretty e + pretty (Var (Just t) p e Nothing) = "var" <+> pretty p <> ":" <+> pretty t <+> "=" <+> pretty e + pretty (Include s) = "#include" <+> pretty s + pretty (Staload Nothing s) = "staload" <+> pretty s + pretty (Staload (Just q) s) = "staload" <+> pretty q <+> "=" <+> pretty s + pretty (CBlock s) = string s + pretty (Comment s) = string s + pretty (OverloadOp _ o n) = "overload" <+> pretty o <+> "with" <+> pretty n + pretty (OverloadIdent _ i n) = "overload" <+> string i <+> "with" <+> pretty n + pretty (Func _ (Fn pref)) = "fn" pretty pref + pretty (Func _ (Fun pref)) = "fun" pretty pref + pretty (Func _ (CastFn pref)) = "castfn" pretty pref + pretty (Func _ (Fnx pref)) = "fnx" pretty pref + pretty (Func _ (And pref)) = "and" pretty pref + pretty (Func _ (Praxi pref)) = "praxi" pretty pref + pretty (Func _ (PrFun pref)) = "prfun" pretty pref + pretty (Func _ (PrFn pref)) = "prfn" pretty pref + pretty (Extern _ d) = "extern" <$> pretty d + pretty (Define s) = string s + pretty (DataProp _ s as ls) = "dataprop" <+> string s <> prettyArgs as <+> "=" <$> prettyDL ls + pretty (ViewTypeDef _ s [] t) = "vtypedef" <+> string s <+> "=" pretty t + pretty (ViewTypeDef _ s as t) = "vtypedef" <+> string s <> prettyArgs as <+> "=" pretty t + pretty (TypeDef _ s [] t) = "typedef" <+> string s <+> "=" <+> pretty t + pretty (TypeDef _ s as t) = "typedef" <+> string s <> prettyArgs as <+> "=" <+> pretty t + pretty (AbsProp _ n as) = "absprop" <+> string n <+> prettyArgs as + pretty (Assume n as e) = "assume" pretty n <> prettyArgs as <+> "=" pretty e + pretty (SymIntr _ n) = "symintr" <+> pretty n + pretty (Stacst _ n t Nothing) = "stacst" pretty n <+> ":" pretty t + pretty (Stacst _ n t (Just e)) = "stacst" pretty n <+> ":" pretty t <+> "=" pretty e + pretty _ = "FIXME" diff --git a/src/Language/ATS/Types.hs b/src/Language/ATS/Types.hs --- a/src/Language/ATS/Types.hs +++ b/src/Language/ATS/Types.hs @@ -34,6 +34,7 @@ , PreFunction (..) , Paired (..) , Bifurcated (..) + , Leaf (..) , StaticExpression (..) , StaticExpressionF (..) , rewriteATS @@ -53,6 +54,9 @@ newtype ATS = ATS { unATS :: [Declaration] } deriving (Show, Eq, Generic, NFData) +data Leaf = Leaf [Universal] String [String] (Maybe Type) + deriving (Show, Eq, Generic, NFData) + -- | Declare something in a scope (a function, value, action, etc.) data Declaration = Func AlexPosn Function | Impl [Arg] Implementation @@ -69,8 +73,8 @@ | RecordViewType String [Arg] [Universal] [(String, Type)] | TypeDef AlexPosn String [Arg] Type | ViewTypeDef AlexPosn String [Arg] Type - | SumType String [Arg] [(String, [String], Maybe Type)] - | SumViewType String [Arg] [(String, [String], Maybe Type)] + | SumType String [Arg] [Leaf] + | SumViewType String [Arg] [Leaf] | AbsType AlexPosn String [Arg] (Maybe Type) | AbsViewType AlexPosn String [Arg] (Maybe Type) | AbsView AlexPosn String [Arg] (Maybe Type) @@ -301,6 +305,7 @@ makeBaseFunctor ''Type -- precedence: rewrite n + 2 * x to n + (2 * x) +-- TODO: rewrite multiple universals when it's the right context? rewriteATS :: Expression -> Expression rewriteATS = cata a where a (PrecedeF e e'@PrecedeList{}) = PrecedeList (e : _exprs e')