language-c99-util (empty) → 0.1.0.0

raw patch · 8 files changed

+523/−0 lines, 8 filesdep +basedep +language-c99setup-changed

Dependencies added: base, language-c99

Files

ChangeLog.md +5/−0
LICENSE +20/−0
Setup.hs +2/−0
language-c99-util.cabal +34/−0
src/Language/C99/Util.hs +9/−0
src/Language/C99/Util/Expr.hs +179/−0
src/Language/C99/Util/IsList.hs +75/−0
src/Language/C99/Util/Wrap.hs +199/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Revision history for language-c99-util++## 0.1.0.0 -- 2019-03-30++* First version. Very basic version with support for copilot.

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2018-2019 Frank Dedden++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ language-c99-util.cabal view

@@ -0,0 +1,34 @@+-- Initial language-c99-util.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                language-c99-util+version:             0.1.0.0+synopsis:            Utilities for language-c99.+description:+  This library contains a number of utility functions and wrappers for the+  'language-c99' package. For an actual high-level approach to writing C99+  programs, see 'language-c99-simple'.+license:             MIT+license-file:        LICENSE+author:              Frank Dedden+maintainer:          Frank Dedden <dev@dedden.net>+-- copyright:+category:            Language+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++source-repository head+  type:     git+  location: git://github.com:fdedden/language-c99-util.git++library+  exposed-modules:   Language.C99.Util+  other-modules:     Language.C99.Util.Wrap,+                     Language.C99.Util.IsList,+                     Language.C99.Util.Expr+  -- other-extensions:+  build-depends:     base >=4.9 && <5,+                     language-c99 == 0.1.*+  hs-source-dirs:    src+  default-language:  Haskell2010

+ src/Language/C99/Util.hs view

@@ -0,0 +1,9 @@+module Language.C99.Util+  ( module Language.C99.Util.Wrap+  , module Language.C99.Util.IsList+  , module Language.C99.Util.Expr+  ) where++import Language.C99.Util.Wrap+import Language.C99.Util.IsList+import Language.C99.Util.Expr

+ src/Language/C99/Util/Expr.hs view

@@ -0,0 +1,179 @@+module Language.C99.Util.Expr+  ( digit+  , nonzerodigit+  , nondigit+  , ident+  , litbool+  , litint+  , litdouble+  , litfloat+  , litstring+  , identdeclr+  ) where++import Data.Char (isDigit)++import Language.C99.AST+import Language.C99.Util.Wrap++-- A digit in Haskell, not C+type HSDigit = Int++digit :: Int -> Digit+digit i = case i of+  0 -> DZero+  1 -> DOne+  2 -> DTwo+  3 -> DThree+  4 -> DFour+  5 -> DFive+  6 -> DSix+  7 -> DSeven+  8 -> DEight+  9 -> DNine+  _ -> error $ show i ++ " is not a digit"++nonzerodigit :: Int -> NonZeroDigit+nonzerodigit i = case i of+  1 -> NZOne+  2 -> NZTwo+  3 -> NZThree+  4 -> NZFour+  5 -> NZFive+  6 -> NZSix+  7 -> NZSeven+  8 -> NZEight+  9 -> NZNine+  _ -> error $ show i ++ " is not a non-zero digit"++nondigit :: Char -> IdentNonDigit+nondigit c = IdentNonDigit $ case c of+  '_' -> NDUnderscore+  'a' -> NDa ;      'A' -> NDA+  'b' -> NDb ;      'B' -> NDB+  'c' -> NDc ;      'C' -> NDC+  'd' -> NDd ;      'D' -> NDD+  'e' -> NDe ;      'E' -> NDE+  'f' -> NDf ;      'F' -> NDF+  'g' -> NDg ;      'G' -> NDG+  'h' -> NDh ;      'H' -> NDH+  'i' -> NDi ;      'I' -> NDI+  'j' -> NDj ;      'J' -> NDJ+  'k' -> NDk ;      'K' -> NDK+  'l' -> NDl ;      'L' -> NDL+  'm' -> NDm ;      'M' -> NDM+  'n' -> NDn ;      'N' -> NDN+  'o' -> NDo ;      'O' -> NDO+  'p' -> NDp ;      'P' -> NDP+  'q' -> NDq ;      'Q' -> NDQ+  'r' -> NDr ;      'R' -> NDR+  's' -> NDs ;      'S' -> NDS+  't' -> NDt ;      'T' -> NDT+  'u' -> NDu ;      'U' -> NDU+  'v' -> NDv ;      'V' -> NDV+  'w' -> NDw ;      'W' -> NDW+  'x' -> NDx ;      'X' -> NDX+  'y' -> NDy ;      'Y' -> NDY+  'z' -> NDz ;      'Z' -> NDZ+  _   -> error $ show c ++ " is not a nondigit"++ident :: String -> Ident+ident (c:cs) = foldl char (IdentBase $ nondigit c) cs where+  char cs c | isDigit c = IdentCons         cs (digit (read [c]))+            | otherwise = IdentConsNonDigit cs (nondigit c)++litbool :: Bool -> PrimExpr+litbool False = PrimConst $ ConstEnum $ Enum (ident "false")+litbool True  = PrimConst $ ConstEnum $ Enum (ident "true")++litint :: Integer -> UnaryExpr+litint i | i == 0 = UnaryPostfix $ PostfixPrim $ constzero+         | i >  0 = UnaryPostfix $ PostfixPrim $ constint i+         | i <  0 = UnaryOp UOMin (CastUnary $ litint (abs i))++litdouble :: Double -> UnaryExpr+litdouble = parse . lex where+  lex :: Double -> (String, String, String)+  lex d | isInfinite d = error "Can't translate an infinite floating point number:"+        | otherwise    = (nat, dec, exp) where+    ds = show d+    e = dropWhile (/='e') ds+    nat = takeWhile (/='.') ds+    dec = takeWhile (/='e') $ tail $ dropWhile (/='.') ds+    exp = case length e of+      0 -> ""+      _ -> tail e++  parse :: (String, String, String) -> UnaryExpr+  parse (nat, dec, exp) = op $ PostfixPrim $ PrimConst $ ConstFloat $ FloatDec $ DecFloatFrac (FracZero (Just nat') dec') exp' Nothing where+    op = case head nat of+      '-' -> UnaryOp UOMin . CastUnary . UnaryPostfix+      _   -> UnaryPostfix+    nat' = case head nat of+      '-' -> digitseq $ digitsc (tail nat)+      _   -> digitseq $ digitsc nat+    dec' = digitseq $ digitsc dec+    exp' = case exp of+      "" -> Nothing+      (e:es)  -> case e of+        '-' -> Just $ E (Just SMinus) (digitseq $ digitsc es)+        _   -> Just $ E Nothing (digitseq $ digitsc (e:es))++litfloat :: Float -> UnaryExpr+litfloat = litdouble . realToFrac++litstring :: String -> UnaryExpr+litstring ss = wrap $ PrimString $ StringLit $ (sl ss) where+  sl :: String -> Maybe SCharSeq+  sl [] = Nothing+  sl cs = Just $ readschar cs++  readschar :: String -> SCharSeq+  readschar (c:cs) = foldl SCharCons (SCharBase $ f c) (map f cs)++  f :: Char -> SChar+  f c | isEscseq c = SCharEsc $ litescseq c+      | otherwise  = SChar c++litescseq :: Char -> EscSeq+litescseq c = case c of+  '\'' -> EscSimple SEQuote+  '\"' -> EscSimple SEDQuote+  -- '\?' -> EscSimple SEQuestion+  '\\' -> EscSimple SEBackSlash+  '\a' -> EscSimple SEa+  '\b' -> EscSimple SEb+  '\f' -> EscSimple SEf+  '\n' -> EscSimple SEn+  '\r' -> EscSimple SEr+  '\t' -> EscSimple SEt+  '\v' -> EscSimple SEv+  otherwise -> error $ show c ++ " is not an escape sequence."++isEscseq :: Char -> Bool+isEscseq c = c `elem` "\'\"\\\a\b\f\n\n\r\t\v"+++identdeclr :: String -> Declr+identdeclr name = Declr Nothing (DirectDeclrIdent $ ident name)+++intdigits :: Integer -> [HSDigit]+intdigits = map (read.return).show++constint :: Integer -> PrimExpr+constint i = PrimConst $ ConstInt $ IntDec (decconst $ intdigits i) Nothing++constzero :: PrimExpr+constzero = PrimConst $ ConstInt $ IntOc Oc0 Nothing++decconst :: [HSDigit] -> DecConst+decconst (d:ds) = foldl step base ds where+  base      = DecBase $ nonzerodigit d+  step xs x = DecCons xs (digit x)++digitseq :: [Int] -> DigitSeq+digitseq (x:xs) = foldl DigitCons (DigitBase (digit x)) (map digit xs) where++digitsc :: [Char] -> [Int]+digitsc cs = map (\x -> read [x]) cs

+ src/Language/C99/Util/IsList.hs view

@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeFamilies #-}++module Language.C99.Util.IsList where++import GHC.Exts++import Language.C99.AST++error_emptylist name = error $ "Empty " ++ name ++ " is not allowed"++instance IsList TypeQualList where+  type Item TypeQualList = TypeQual+  fromList []     = error_emptylist "TypeQualList"+  fromList (x:xs) = foldl TypeQualCons (TypeQualBase x) xs+  toList = undefined+++instance IsList StructDeclnList where+  type Item StructDeclnList = StructDecln+  fromList []     = error_emptylist "StructDeclnList"+  fromList (x:xs) = foldl StructDeclnCons (StructDeclnBase x) xs+  toList = undefined++instance IsList ArgExprList where+  type Item ArgExprList = AssignExpr+  fromList []     = error_emptylist "ArgExprList"+  fromList (x:xs) = foldl ArgExprListCons (ArgExprListBase x) xs++instance IsList InitList where+  type Item InitList = Init+  fromList []     = error_emptylist "InitExprList"+  fromList (x:xs) = foldl step base xs where+    base      = InitBase Nothing x+    step ys y = InitCons ys Nothing y++instance IsList BlockItemList where+  type Item BlockItemList = BlockItem+  fromList []     = error_emptylist "BlockItemList"+  fromList (x:xs) = foldl BlockItemCons (BlockItemBase x) xs++instance IsList TransUnit where+  type Item TransUnit = ExtDecln+  fromList []     = error_emptylist "TransUnit"+  fromList (x:xs) = foldl TransUnitCons (TransUnitBase x) xs++instance IsList DeclnList where+  type Item DeclnList = Decln+  fromList []     = error_emptylist "DeclnList"+  fromList (x:xs) = foldl DeclnCons (DeclnBase x) xs++hcharseq :: [HChar] -> HCharSeq+hcharseq []     = error_emptylist "HCharSeq"+hcharseq (x:xs) = foldl HCharCons (HCharBase x) xs++qcharseq :: [QChar] -> QCharSeq+qcharseq []     = error_emptylist "QCharSeq"+qcharseq (x:xs) = foldl QCharCons (QCharBase x) xs++group :: [GroupPart] -> Group+group []     = error_emptylist "HCharSeq"+group (x:xs) = foldl GroupCons (GroupBase x) xs++pptokens :: [PreprocToken] -> PPTokens+pptokens []     = error_emptylist "PPTokens"+pptokens (x:xs) = foldl PPTokensCons (PPTokensBase x) xs++paramlist :: [ParamDecln] -> ParamList+paramlist []     = error_emptylist "ParamList"+paramlist (x:xs) = foldl ParamCons (ParamBase x) xs++voidparamlist :: [ParamDecln] -> ParamList+voidparamlist [] =+  paramlist [ParamDeclnAbstract (DeclnSpecsType TVoid Nothing) Nothing]+voidparamlist xs = paramlist xs

+ src/Language/C99/Util/Wrap.hs view

@@ -0,0 +1,199 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.C99.Util.Wrap+  ( Wrap+  , wrap+  ) where++import Language.C99.AST+++{- Wraps only a single layer -}+class WrapStep a b | a -> b  where+  wrapstep :: a -> b++instance WrapStep Expr PrimExpr where+  wrapstep = PrimExpr . wrap++instance WrapStep PrimExpr PostfixExpr where+  wrapstep = PostfixPrim . wrap++instance WrapStep PostfixExpr UnaryExpr where+  wrapstep = UnaryPostfix . wrap++instance WrapStep UnaryExpr CastExpr where+  wrapstep = CastUnary . wrap++instance WrapStep CastExpr MultExpr where+  wrapstep = MultCast . wrap++instance WrapStep MultExpr AddExpr where+  wrapstep = AddMult . wrap++instance WrapStep AddExpr ShiftExpr where+  wrapstep = ShiftAdd . wrap++instance WrapStep ShiftExpr RelExpr where+  wrapstep = RelShift . wrap++instance WrapStep RelExpr EqExpr where+  wrapstep = EqRel . wrap++instance WrapStep EqExpr AndExpr where+  wrapstep = AndEq . wrap++instance WrapStep AndExpr XOrExpr where+  wrapstep = XOrAnd . wrap++instance WrapStep XOrExpr OrExpr where+  wrapstep = OrXOr . wrap++instance WrapStep OrExpr LAndExpr where+  wrapstep = LAndOr . wrap++instance WrapStep LAndExpr LOrExpr where+  wrapstep = LOrAnd . wrap++instance WrapStep LOrExpr CondExpr where+  wrapstep = CondLOr . wrap++instance WrapStep CondExpr AssignExpr where+  wrapstep = AssignCond . wrap++instance WrapStep AssignExpr Expr where+  wrapstep = ExprAssign . wrap+++{- Wraps multiple layers -}+{- We write specific instances to help Haskell's type system. Using variables+   allows us to wrap _anything_, which will lead to inifite loops if no+   suitable instance is found.+-}+class Wrap a b where+  wrap    :: a -> b++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b PrimExpr)+  => Wrap a PrimExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b PostfixExpr)+  => Wrap a PostfixExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b UnaryExpr)+  => Wrap a UnaryExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b CastExpr)+  => Wrap a CastExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b MultExpr)+  => Wrap a MultExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b AddExpr)+  => Wrap a AddExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b ShiftExpr)+  => Wrap a ShiftExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b RelExpr)+  => Wrap a RelExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b EqExpr)+  => Wrap a EqExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b AndExpr)+  => Wrap a AndExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b OrExpr)+  => Wrap a OrExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b XOrExpr)+  => Wrap a XOrExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b LAndExpr)+  => Wrap a LAndExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b LOrExpr)+  => Wrap a LOrExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b CondExpr)+  => Wrap a CondExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b AssignExpr)+  => Wrap a AssignExpr where+    wrap = wrap . wrapstep++instance {-# OVERLAPPABLE #-} (WrapStep a b, Wrap b Expr)+  => Wrap a Expr where+    wrap = wrap . wrapstep+++{- We provide specific identity instances as well, to eliminate unsolvable+   overlapping instances.+-}+instance {-# OVERLAPPABLE #-} Wrap PrimExpr PrimExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap PostfixExpr PostfixExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap UnaryExpr UnaryExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap CastExpr CastExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap MultExpr MultExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap AddExpr AddExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap ShiftExpr ShiftExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap RelExpr RelExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap EqExpr EqExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap AndExpr AndExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap OrExpr OrExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap XOrExpr XOrExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap LAndExpr LAndExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap LOrExpr LOrExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap CondExpr CondExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap AssignExpr AssignExpr where+  wrap = id++instance {-# OVERLAPPABLE #-} Wrap Expr Expr where+  wrap = id