sugar-data (empty) → 0.0.0.0
raw patch · 6 files changed
+259/−0 lines, 6 filesdep +aesondep +basedep +hspec
Dependencies added: aeson, base, hspec, sugar, sugar-data, tasty, tasty-hspec, text
Files
- CHANGELOG.md +7/−0
- LICENSE +14/−0
- README.md +0/−0
- src/Sugar/Data.hs +175/−0
- sugar-data.cabal +50/−0
- tests/Main.hs +13/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Change log++sugar uses [Semantic Versioning][].+The change log is available through the [releases on GitHub][].++[Semantic Versioning]: http://semver.org/spec/v2.0.0.html+[releases on GitHub]: https://github.com/jxv/sugar/releases
+ LICENSE view
@@ -0,0 +1,14 @@+The BSD Zero Clause License (0BSD)++Copyright (c) 2022 Joe Vargas.++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY+AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR+PERFORMANCE OF THIS SOFTWARE.
+ README.md view
+ src/Sugar/Data.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE OverloadedStrings #-}+module Sugar.Data+ ( Type(..)+ , TypeRef(..)+ , Ty(..)+ , Rec(..)+ , Mem(..)+ , Adt(..)+ , Cons(..)+ , ConsValue(..)+ , Err(..)+ , Error(..)+ , ParamFns(..)+ , tokenToTypes+ , tokenToType+ ) where++import qualified Data.Text as T+import Data.Text (Text)+import Sugar++data Type a m c+ = Type'Ty (Ty a)+ | Type'Rec (Rec a m)+ | Type'Adt (Adt a m c)+ deriving (Show, Eq)++data TypeRef = TypeRef+ { trName :: Text+ , trParams :: [TypeRef]+ , trLoc :: SourceLocation+ } deriving (Show, Eq)++data Ty a = Ty+ { tyName :: Text+ , tyParam :: Maybe a+ , tyType :: TypeRef+ , tyLoc :: SourceLocation+ } deriving (Show, Eq)++data Rec a m = Rec+ { recName :: Text+ , recParam :: Maybe a+ , recMems :: [Mem m]+ , recLoc :: SourceLocation+ } deriving (Show, Eq)++data Mem m = Mem+ { memLabel :: Text+ , memParam :: Maybe m+ , memType :: TypeRef+ , memLoc :: SourceLocation+ } deriving (Show, Eq)++data Adt a m c = Adt+ { adtName :: Text+ , adtParam :: Maybe a+ , adtCons :: [Cons m c]+ , adtLoc :: SourceLocation+ } deriving (Show, Eq)++data Cons m c = Cons+ { consTag :: Text+ , consParam :: Maybe c+ , consValue :: ConsValue m+ , consLoc :: SourceLocation+ } deriving (Show, Eq)++data ConsValue m+ = ConsValue'None+ | ConsValue'TypeRef [TypeRef]+ | ConsValue'Mems [Mem m]+ deriving (Show, Eq)++--++data Err e+ = Err'Info e+ | Err'NotTopLevelMap+ | Err'TypeMismatch+ | Err'TypeRefMismatch+ | Err'TypeRefParamsMismatch+ | Err'MemMismatch+ | Err'MemsMismatch+ | Err'ConsMismatch+ deriving (Show, Eq)++data Error e = Error+ { errorLoc :: SourceLocation+ , errorInfo :: Err e+ } deriving (Show, Eq)++data ParamFns a m c e = ParamFns+ { paramFnType :: [TokenStep] -> Either [Error e] a+ , paramFnMem :: [TokenStep] -> Either [Error e] m+ , paramFnCons :: [TokenStep] -> Either [Error e] c+ }++tokenToTypes :: ParamFns a m c e -> TokenStep -> Either [Error e] [Type a m c]+tokenToTypes fns (_, Token'Map ts _) = mapWithErrs (uncurry $ tokenToType fns) ts+tokenToTypes _ (loc, _) = Left [Error loc Err'NotTopLevelMap]++tokenToType :: ParamFns a m c e -> TokenStep -> TokenStep -> Either [Error e] (Type a m c)+tokenToType fns n v =+ case Type'Ty <$> tokenToTy fns n v of+ Right ty -> pure ty+ Left tyErrs -> case Type'Rec <$> tokenToRec fns n v of+ Right rec -> pure rec+ Left recErrs -> case Type'Adt <$> tokenToAdt fns n v of+ Right adt -> pure adt+ Left adtErrs -> Left $ betterErrs (betterErrs tyErrs recErrs) adtErrs++betterErrs :: [Error e] -> [Error e] -> [Error e]+betterErrs [Error _ Err'TypeMismatch] ys = ys+betterErrs xs [Error _ Err'TypeMismatch] = xs+betterErrs _ ys = ys -- FIXME: May not be the best fall-through approach++tokenTypeRef :: TokenStep -> Either [Error e] TypeRef+tokenTypeRef (loc, Token'Text name Nothing) = Right $ TypeRef (T.pack name) [] loc+tokenTypeRef (loc, Token'Text name (Just params)) = TypeRef (T.pack name) <$> (mapWithErrs tokenTypeRef params) <*> pure loc+tokenTypeRef (loc, _) = Left [Error loc Err'TypeRefMismatch]++tokenToTy :: ParamFns a m c e -> TokenStep -> TokenStep -> Either [Error e] (Ty a)+tokenToTy fns (loc, Token'Text t params) v = Ty (T.pack t) <$> tokenParams (paramFnType fns) params <*> tokenTypeRef v <*> pure loc+tokenToTy _ _ (loc, _) = Left [Error loc Err'TypeMismatch]++tokenToRec :: ParamFns a m c e -> TokenStep -> TokenStep -> Either [Error e] (Rec a m)+tokenToRec fns (loc, Token'Text name params) v = Rec (T.pack name) <$> tokenParams (paramFnType fns) params <*> tokenToMems fns v <*> pure loc+tokenToRec _ _ (loc, _) = Left [Error loc Err'TypeMismatch]++tokenToMems :: ParamFns a m c e -> TokenStep -> Either [Error e] [Mem m]+tokenToMems fns (_, Token'Map mems Nothing) = tokenToMems' fns mems+tokenToMems _ (loc, _) = Left [Error loc Err'MemsMismatch]++tokenToMems' :: ParamFns a m c e -> [(TokenStep,TokenStep)] -> Either [Error e] [Mem m]+tokenToMems' fns = mapWithErrs (uncurry $ tokenToMem fns)++tokenToMem :: ParamFns a m c e -> TokenStep -> TokenStep -> Either [Error e] (Mem m)+tokenToMem fns (loc, Token'Text name params) s = Mem (T.pack name) <$> tokenParams (paramFnMem fns) params <*> tokenTypeRef s <*> pure loc+tokenToMem _ _ (loc, _) = Left [Error loc Err'MemMismatch]++tokenToAdt :: ParamFns a m c e -> TokenStep -> TokenStep -> Either [Error e] (Adt a m c)+tokenToAdt fns (loc, Token'Text name params) (_, Token'List conss _ Nothing) = Adt (T.pack name) <$> tokenParams (paramFnType fns) params <*> mapWithErrs (tokenToCons fns) conss <*> pure loc+tokenToAdt _ _ (loc, _) = Left [Error loc Err'TypeMismatch]++tokenToCons :: ParamFns a m c e -> TokenStep -> Either [Error e] (Cons m c)+tokenToCons fns (loc, Token'Text name params) = Cons (T.pack name) <$> tokenParams (paramFnCons fns) params <*> pure ConsValue'None <*> pure loc+tokenToCons fns (loc, Token'List [(_, Token'Text name Nothing)] _ params) = Cons (T.pack name) <$> tokenParams (paramFnCons fns) params <*> pure ConsValue'None <*> pure loc+tokenToCons fns (loc, Token'List [(_, Token'Text name Nothing), (_, Token'Map mems Nothing)] _ params) = do+ ms <- tokenToMems' fns mems+ param <- tokenParams (paramFnCons fns) params+ return $ Cons+ (T.pack name)+ param+ (if null ms+ then ConsValue'None+ else ConsValue'Mems ms)+ loc+tokenToCons fns (loc, (Token'List ((_, Token'Text name Nothing):xs) _ params)) = Cons (T.pack name) <$> tokenParams (paramFnCons fns) params <*> (ConsValue'TypeRef <$> mapWithErrs tokenTypeRef xs) <*> pure loc+tokenToCons _ (loc,_) = Left [Error loc Err'ConsMismatch]++mapWithErrs :: (a -> Either [Error e] b) -> [a] -> Either [Error e] [b]+mapWithErrs _ [] = Right []+mapWithErrs f (x:xs) = case f x of+ Left es -> case mapWithErrs f xs of+ Left es' -> Left $ es ++ es'+ Right _ -> Left es+ Right y -> case mapWithErrs f xs of+ Left es -> Left es+ Right ys -> Right $ y : ys++tokenParams :: ([TokenStep] -> Either [Error e] a) -> Maybe [TokenStep] -> Either [Error e] (Maybe a)+tokenParams f params = case params of+ Nothing -> pure Nothing+ Just ps -> Just <$> f ps
+ sugar-data.cabal view
@@ -0,0 +1,50 @@+name: sugar-data+version: 0.0.0.0+synopsis: Convert sugar to common data types for code generation+homepage: https://github.com/jxv/sugar#readme+description: Please see the README on GitHub at <https://github.com/jxv/sugar#readme>+category: Text, Configuration+bug-reports: https://github.com/jxv/sugar/issues+author: Joe Vargas+maintainer: Joe Vargas+license: OtherLicense+license-file: LICENSE+build-type: Simple+cabal-version: 1.14+extra-source-files:+ CHANGELOG.md+ LICENSE+ README.md++source-repository head+ type: git+ location: https://github.com/jxv/sugar++library+ exposed-modules:+ Sugar.Data+ hs-source-dirs:+ src+ default-extensions:+ ghc-options: -Wall+ build-depends:+ aeson+ , base >=4.7 && <5+ , sugar == 0.0.1.1+ , text+ default-language: Haskell2010++test-suite sugar-data-tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ tests+ ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+ build-depends:+ base+ , hspec+ , sugar+ , sugar-data+ , tasty+ , tasty-hspec+ default-language: Haskell2010
+ tests/Main.hs view
@@ -0,0 +1,13 @@+import qualified Test.Tasty+import Test.Tasty.Hspec+import Test.Hspec++main :: IO ()+main = do+ test <- testSpec "sugar" spec+ Test.Tasty.defaultMain test++spec :: Spec+spec = parallel $ do+ it "is trivially true" $ do+ True `shouldBe` True